This post is a post published in the VB version. Originally posted: http://community.9cbs.net/expert/topic/3649/3649442.xml? Temp = .6041529
1. How do I eliminate the Beep sound when I press it in TextBox? Private sub text1_keypress (Keyascii As INTEGER) if keyascii = 13 Then Keyascii = 0 End IFEND SUB
2.T.TextBox is automatically selected when the focus is obtained. Private sub text1_gotfocus () text1.selstart = 0 text1.sellength = len (text1.text) End Sub
3. Block the TEXTBOX control itself right-click and display your own menu. Method 1: Private Sub Text1_Mousedown (Button As INTEGER, Shift As Integer, x as single, y _as single) ife = 2 TEXT1.ENABLED = false text1.enabled = true popupmenu mymenu end iFend SUB
Method two: callback function module: Option ExplicitPublic OldWindowProc As Long 'to save the default window function address Public Const WM_CONTEXTMENU = & H7B' when the right-click a text box, generating the message Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( ByVal hWnd _ As Long, ByVal nIndex As Long) As LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function CallWindowProc Lib "user32" alias "CallWindowProcA" (ByVal _ lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Function SubClass_WndMessage (ByVal hWnd As Long, ByVal Msg As Long, ByVal wp _ As Long, ByVal lp As Long) As Long 'if the message is not WM_CONTEXTMENU, is called the default window function processing If Msg <> WM_CONTEXTMENU Then SubClass_WndMessage = CallWindowProc (OldWindowProc, hWnd, Msg, wp, lp) Exit function End If SubClass_WndMessage = TrueEnd function In the form: Private const gwl_wndproc = (-4) Private sub text1_mousedown (Button as INTEG er, Shift As Integer, X As Single, Y _ As Single) If Button = 1 Then Exit Sub OldWindowProc = GetWindowLong (Text1.hWnd, GWL_WNDPROC) 'to obtain the address of the window function' instead of processing the message with a window function SubClass_WndMessage Call SetWindowLong (Text1 .hWnd, GWL_WNDPROC, AddressOf SubClass_WndMessage) End SubPrivate Sub Text1_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then Exit Sub 'restore default window function Call SetWindowLong (Text1.hWnd, GWL_WNDPROC , OldwindowProc) Popupmenu Mymenuend Sub
4. Set TEXTBOX is readonly Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd _ As Long, ByVal nIndex As Long) As LongPrivate Const GWL_STYLE = (-16) Private Const EM_SETREADONLY = & HCFPrivate Sub Command1_Click () Dim l As Long If (GetWindowLong (Text1.hwnd, GWL_STYLE) And & H800) The Text1.Text = "this is a ie = RGB (Text1.hwnd, Em_setReadonly, false, vbnull) textonly, false, vbnull) textonly, false, vbnull (TEXT1.BACKCOLOR = RGB) 255, 255, 255) Set the background to white command1.caption = "Read & Write" else text1.text = "this is a ready text box." The text window is a readable and writable window, set to read-only window L = SendMessage (Text1.hwnd, EM_SETREADONLY, True, vbNull) Text1.BackColor = vbInactiveBorder 'to set the background gray Command1.Caption = "& ReadOnly" End IfEnd Sub5. Instead of using the API function MessageBox MSGBOX Timer control function may be such that normal operation
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As _ Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As LongPrivate Sub Command1_Click () MsgBox "clock becomes invalid" End SubPrivate Sub command2_click () MessageBox Me.hwnd, "Time", "HEHE", 0nd Subprivate Sub Timer1_timer () Static I as Integer i = i 1 Text1.Text = IEND SUB
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _ hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal Cy _As Long, ByVal wFlags As Long) As LongPublic Sub SetOnTop ( BYVAL ISONTOP AS INTEGER DIM RTN As long if isotop = 1 Then RTN = setWindowPos (form1.hwnd, -1, 0, 0, 0, 0, 3) else = setWindowPos (Form1.hWnd, -2, 0, 0 , 0, 0, 3) End IFEND SUBPRIVATE SUB Command1_Click () SetONTOP 1 'Place the window to the top of Subprivate Sub Command2_click () setontop 0nd Sub7. Only allows running a program instance (using a mutex)
Select the Startup object as sub main () module: Public Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _ (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName _ As String) As LongPublic Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As LongEnd TypePublic Const ERROR_ALREADY_EXISTS = 183 & Private Sub Main () Dim sa As SECURITY_ATTRIBUTES sa.bInheritHandle = 1 sa.lpSecurityDescriptor = 0 sa.nLength = Len (sa) Debug.Print CreateMutex (sa, 1, App.Title) 'can be the line Never delete the debug.print Err.lastdllerror if (Err.lastdller = error_Already_exists) Then Msgbox "More Tan One Instance" else form1.show end ifend sub
8. The form title bar flashes Option ExplicitPrivate Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert _ As Long) As LongPrivate Sub tmrFlash_Timer () Static mFlash As Boolean FlashWindow hwnd, Not mFlashEnd Sub8. Screenshot
Method 1: Use analog keyboard Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _ ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Const theScreen = 1Const theForm = 0Private Sub Command1_Click () Call keybd_event ( VBKEYSNAPSHOT, Theform, 0, 0) 'If TheForm is changed to Thescreen, Copy Whole ScreenDoEventsPictTure1.Picture = Clipboard.getData (VBCFBITMAP) End Sub9. Sign up for the program
Method a: modifying the registry Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id _ As Long, ByVal fsModifiers As Long, ByVal vk As Long) As LongPrivate Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long , ByVal id _ As Long) As LongPrivate Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, _ ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal _ wRemoveMsg As Long) As LongPrivate Declare Function WaitMessage Lib "user32" () As LongPrivate Type POINTAPI x As Long y As LongEnd TypePrivate Type Msg hWnd As Long Message As Long wParam As Long lParam As Long time As Long pt As POINTAPIEnd Type 'statement constant Private Const MOD_ALT = & H1Private Const MOD_CONTROL = & H2Private Const MOD_SHIFT = & H4Private Const PM_REMOVE = & H1Private Const WM_HOTKEY = & H312Private HotKey_Fg as BooleanPrivate Sub Form_Load () Dim Message as Msg 'register as hot keys Ctrl Y RegisterHotKey Me.hWnd, & HBFFF &, MOD_CONTROL, vb KeyY 'RegisterHotKey Me.hWnd, & HBFF2 &, MOD_CONTROL, vbKeyU Me.Show Form1.Hide' message waiting HotKey_Fg = False Do While Not HotKey_Fg 'message waiting WaitMessage' checks whether the hot key has been pressed If PeekMessage (Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then Form1.Show 1 End If 'transfer control, allows the operating system to process other events DoEvents loopEnd SubPrivate Sub Form_Unload (Cancel As Integer) HotKey_Fg = True' hot key registration revocation Call UnregisterHotKey (Me.hWnd, & Hbfff &) End Sub
Method two: SendMessagePrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Const WM_SETHOTKEY = & H32Private Const HOTKEYF_SHIFT = & H1Private Const HOTKEYF_ALT = & H4Private SUB FORM_LOAD () DIM L AS Long Dim WhoTKey As Long Whotkey = (HotKeyf_alt) * (2 ^ 8) 65 'Definition Alt A is the hotkey L = sendMessage (me.hwnd, wm_sethoTKey, WHOTKEY, 0) End Sub10. The boundless box form icon is displayed in the status bar. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long) As LongConst GWL_STYLE = (-16 &) Const WS_SYSMENU = & H80000Private Sub Form_Load () 'Make Form's Icon visible in the taskbarSetWindowLong Me.hWnd, GWL_STYLE, GetWindowLong (Me.hWnd, GWL_STYLE) Or WS_SYSMENUEnd Sub
11. Record some of the size and location of the form and some settings in the program Private sub Form_Load () me.width = getSetting (app.title, me.name, "width", 7200) me.height = getSetting (app.title, Me.Name, "HEIGHT", 6300) Me.Top = getSetting (app.title, me.name, "top", 100) me.left = getsetting (app.title, me.name, "left", 100) Check1.value = getSetting (app.title, me.name, "check1", 0) End subprivate sub form_unload (Cancel AS Integer) Call Savesetting (App.Title, Me.Name, "Width", Me.Width Call Savesetting (App.title, me.name, "height", me.height) Call Savesetting (app.title, me.name, "top", me.top) Call Savesetting (app.title, me.name, "left" , Me.left) Call Savesetting (App.Title, Me.Name, "Check1", Check1.Value) End Sub12. Solving the flash phenomenon when MSChart control data change 1, add one in the form with MSChart controls PictureBox controls such as Mschart1 and Picture1. 2, match the size of Picture1 and MSChart1, the same position is the same (aligned by left alignment and top). 3, make Picture1 at the front end of the MSChart1, set the Visible of Picture1 to false, which is invisible. Picture1 is only displayed when the data is refreshed. 'Refresh data pro_newchar () DIM v_newchar ()' n dimensional group ... Picture1.visible = true mschart1.ChartData = v_newchar 'Re-assinds Mschart1, namely refresh data Mschart1.editCopy' Copy the image of the current chart to the clip Picture1.picture = clipboard.getdata () 'Give the picture1 assignment the image End Sub like each refresh data, the picture displayed by Picture1 does not generate a flashing phenomenon.
13. Right-click Menu Design Bless Forms When you use a menu editor, you will automatically change into a form of a border. At this time, you can in another form (in general your program If you do not only one form, if you only have one, you can use the class to write the class, add the right button) Edit menu (Visible property is set to false), then call it in this form. The modes are as follows: Private Sub Form_Mousedown (Button As INTEGER, SHIFT AS INTEGER, X as single, y as single) ife = 2 ThenPopUpMenu Form2.Mymenuend IFEND SUB
14. Create rounded no window frame Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Integer, ByVal Y1 _ As Integer, ByVal X2 As Integer, ByVal Y2 As Integer, ByVal x3 As Integer, ByVal y3 As _ Integer) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As _ Long, ByVal bRedraw As Boolean) As LongPrivate Sub Form_Load () hround = CreateRoundRectRgn (0, 0, Scalex (Form1.Scalewidth, Vbtwips, VBPixels), _ Scaley (Form1.ScaleHeight, VBTWIPS, VBPIXELS), 20, 20) SETWINDOWRGN Me.hWnd, HROUND, TRUEDELETEOBJECT HROUNDEND SUB
15. The method of dragging the title bar is not a form: Private Declare Function ReleaseCapture Lib "user32" () As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Const HTCAPTION = 2Private Const WM_NCLBUTTONDOWN = & HA1Private Sub Form_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim ncl As Long Dim rel As Long If Button = 1 Then i = ReleaseCapture () ncl = SendMessage (hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0) End IfEnd Sub method two: callback function module: Public Const GWL_WNDPROC = (-4) Public Const WM_NCHITTEST = & H84Public Const HTCLIENT = 1Public Const HTCAPTION = 2Declare function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal _ lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As LongDeclare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd AS _LONG, BYVAL NINDEX As Long AS LongdeClare FU nction SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As _ Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic prevWndProc As LongFunction WndProc (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal _Param As Long) As Long WndProc = CallWindowProc (prevWndProc, hWnd, Msg, wParam, lParam) If Msg = WM_NCHITTEST And WndProc = HTCLIENT Then WndProc = HTCAPTION End IfEnd Function form: Private Sub Form_Load () prevWndProc =
GetWindowLong (Me.hWnd, GWL_WNDPROC) SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProcEnd SubPrivate Sub Form_Unload (Cancel As Integer) SetWindowLong Me.hWnd, GWL_WNDPROC, prevWndProcEnd Sub16. Semitransparent form Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _ ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPrivate Const WS_EX_LAYERED = & H80000Private Const LWA_ALPHA = & H2Private Const GWL_EXSTYLE = (-20) Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal _ hwnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal _ hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Sub Form_Load () Dim rtn As Long rtn = GetWindowLong (Me.hwnd, GWL_EXSTYLE) 'previously taken window style rtn = rtn Or WS_EX_LAYERED' is added on the form that the new style WS_EX_LAYERED SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn 'assigned to the new styles form SetLayeredWindowAttributes Me.hwnd, 0, 200 LWA_ALPHAEND SUB
17. Power-on start (function and constant declaration) Private Sub Form_Load () DIM HKEY As Long, Subkey AS String, Exe As String Subkey = "Software / Microsoft / Windows / CurrentVersion / Run" Exe = "Performable Path" RegcreateKey HKEY_CURRENT_USER, SUBKEY, HKEY RegSetValueex HKey, "Autorun", 0, Reg_SZ, BYVAL EXE, LENB (STRCONV (EXE, VBFROMUNICODE) 1 RegcloseKey Hkeyend Sub
18. Close the display Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _ As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongConst WM_SYSCOMMAND = & H112 & Const SC_MONITORPOWER = & HF170 & Private Sub Command1_Click () SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 2 & 'turn off the display end SubPrivate Sub Command2_Click () SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1 &' to open the display end Sub19. SHELL closed automatically opened by a program at the end of the program. Private Const PROCESS_QUERY_INFORMATION = & H400 'to close the open from SHELL function file Private Const PROCESS_TERMINATE = & H1Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function TerminateProcess Lib "kernel32 "(ByVal hProcess As Long, _ ByVal uExitCode As Long) As LongDim ProcessId As LongPrivate Sub Command1_Click () ProcessId = Shell (" notepad.exe. ", vbNormalFocus) End SubPrivate Sub Form_Unload (Cancel As Integer) Dim hProcess As Long hProcess = OpenProcess (Process_Terminate or Process_Query_Information, false, _ processid) Call TerminateProcess (HProcess, 3838) End Sub
20. Close, restart computer public declare function exitwindowsex lib "user32" alias "exitwindowsex" (byval _ uflags as long) (byval dwreserved as long) AS LONGEXITWITWINDOWSEX 1,0 shutdown EXITWINDOWSEX 0,1 restart
21. Show Shutdown Tips Private Declare Function Shrestartsystemmb Lib "Shell32" Alias "# 59" (Byval Howner _ as long, Byval Sextraprompt As String,
ByVal uFlags As Long) As LongConst EWX_LOGOFF = 0Const EWX_SHUTDOWN = 1Const EWX_REBOOT = 2Const EWX_FORCE = 4Const EWX_POWEROFF = 8Private Sub Command1_Click () SHRestartSystemMB Me.hWnd, PROMPT, EWX_LOGOFFEnd Sub22. Right after the shock he must tray icon can disappear, how to do? Case WM_RBUTTONUP 'mouse right-click on the icon to pop up menu setForegroundWindow me.hwnd me.popupmenu mnutray plus a setForeGroup
23. progressbar embedded in statusbar Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal _ hWndNewParent As Long) As LongPrivate Sub Command1_Click () With ProgressBar1 .Max = 1000 Dim i As Integer For i = 1 To 1000. Value = i Next i End WithEnd SubPrivate Sub Form_Load () ProgressBar1.Appearance = ccFlat SetParent ProgressBar1.hWnd, StatusBar1.hWnd ProgressBar1.Left = StatusBar1.Panels (1) .Left ProgressBar1.Top = 100 ProgressBar1.Width = StatusBar1.Panels ( 1) .width - 50 progressbar1.height = statusbar1.height - 150nd sub 'relative location You can toner yourself
24. Make your program interface with the XP style to generate a file that is the suffix of your executable as an exe.manifest, and placed in the same path in the same path. Code added: Private Declare Sub InitCommonControls Lib "comctl32.dll" () Private Sub Form_Initialize () InitCommonControlsEnd Sub Note: 1 toolbar control must use Microsoft Windows Common Controls 5.0, rather than using Microsoft Windows Common Controls 6.0. Because of this
The INITCOMMONTROLS API function is located in ComctL32.dll (Microsoft Windows Common Controls 5.0 control). 2 Placing a single button in the Frame control Some "trouble"! In order to solve this problem, you can play the radio button in the Picture control (as a container as a container), will
The Picture control is placed in the Frame control. 3 After you must compile, you can see the content in the EXE.manifest file, you can use NOTEPAD editing.
Add another PictureBox, then: Private Const WM_PAINT = & HFPrivate Const WM_PRINT = & H317Private Const PRF_CLIENT = & H4 & Private Const PRF_CHILDREN = & H10 & Private Const PRF_OWNED = & H20 & Private Const PHYSICALOFFSETX As Long = 112Private Const PHYSICALOFFSETY As Long = 113Private Declare Function SendMessage Lib "user32" Alias "SendMessageA "(ByVal hwnd _ As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Declare Function GetDeviceCaps Lib" gdi32 "(ByVal hdc As Long, ByVal nindex _ As Long) As Longprivate Sub Form_Load () Picture1.AutoRedraw = True Picture2.AutoRedraw = True Picture2.BorderStyle = 0 Picture2.Visible = FalseEnd SubPrivate Sub Command2_Click () Dim retval As Long, xmargin As Single, ymargin As Single Dim x As Single, y As Single x = 1: y = 1 with printer .scalemode = vbinches xmargin = getDevicecaps (.hdc, physicaloffsetx) xmargin = (xmargin * .twipsperpixelx) / 1440 ymargin = getDevicecaps (.hdc, physicalof) FSETY) ymargin = (ymargin * .TwipsPerPixelY) / 1440 Picture2.Width = Picture1.Width Picture2.Height = Picture1.Height DoEvents Picture1.SetFocus retval = SendMessage (Picture1.hwnd, WM_PAINT, Picture2.hdc, 0) retval = SendMessage ( Picture1.hwnd, wm_print, picture2.hdc, _ prf_children printer.print "" .PaintPicture Picture2.Image, x - xmargin, y - ymargin .enddoc End Withend Sub.
26. Skating is as follows: SUB BUBBLESORT (List () as double) DIM FIRS DOUBLE, LAST AS DOUBEDIM I AS DOUBLER, J AS INTEGERDIM TEMP AS DOUBLEFIRST = LBOUND (list) last = ubound (list) for i = first to Last - 1for J = i 1 to lastif List (i)> list (j) TenTemp = list (j) list (j) = list (i) list (i) = TempendixT JNext IEND SUB27. Clear Recycle Bank
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias _ "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, _ ByVal dwFlags As Long) As LongPrivate Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As LongPrivate Const SHERB_NOCONFIRMATION = & H1Private Const SHERB_NOPROGRESSUI = & H2Private Const SHERB_NOSOUND = & H4Private Sub Command1_Click () Dim retval As Long 'return value retval = SHEmptyRecycleBin (RecycleBin.hwnd, "", SHERB_NOPROGRESSUI)' empty trash confirm 'if an error occurs, the Recycle Bin returns to FIG. illustrates If retval <> 0 Then 'error retval = SHUpdateRecycleBinIcon () End IfEnd SubPrivate Sub Command2_Click () Dim retval As Long' return value 'empty the trash does not confirm retval = SHEmptyRecycleBin (RecycleBin.hwnd, "", SHERB_NOCONFIRMATION)' If There is an error, then return to the recycling station illustration if return <> 0 Then 'Error Retval = ShupdateRecyclebinicon () end if command1_clickend submmand1_clickend submmand1_clickend Sub
28. The system folder path obtained Private Declare Function GetSystemDirectory Lib "kernel32" Alias _ "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As LongPrivate Sub Command1_Click () Dim syspath As String Dim len5 As Long syspath = String ( 255, 0) LEN5 = GetSystemDirectory (syspath, 256) syspath = left (syspath, instr (1, syspath, chr (0)) - 1) Debug.print "System path:"; syspathend sub29. Dynamically add controls and response events Option Explicit increase controls Private Sub Command1_Click () If NewButton is Nothing Then 'add new buttons cmdNew Set NewButton = Controls.Add ( "VB' new command button Private WithEvents NewButton as CommandButton by using the WithEvents keyword to declare an object variable to ' .Commandbutton "," cmdnew ", me) 'Determines the location of the new button CMDNEW NEWBUTTON.MOVE COMMAND1.LEFT Command1.Width 240, command1.top newbutton.caption =" Added button "newbutton.visible = true end If End Sub 'Remove Control (Note: You can only remove dynamic increased controls) Private submmand2_click () if newbutton is nothing the else controls.remove newbutton set newbut Ton = Nothing end if End sub 'Click Events of the Add Control Private Sub NewButton_Click () MsgBox "You selected a dynamic added button! "End Sub 30. give disk serial number Function GetSerialNumber (strDrive As String) As Long Dim SerialNum As Long Dim Res As Long Dim Temp1 As String Dim Temp2 As String Temp1 = String $ (255, Chr $ (0)) Temp2 = String $ (255, chr $ (0)) res = getVolumeInformation (strDrive, temp1, len (temp1), serialnum, 0, 0, temp2, _ len (temp2) GetSerialNumber = serialNuMend function call form label1.caption = getserialnumber (" C: / ")
31. Open Screen Protection Private Declare Function SendMessage Lib "User32" Alias "SendMessagea" (Byval Hwnd _ As Long, Byval WMSG As Long, Byval WParamas Long, LParam As Any) As long 'The message we want to call, in MSDN Search WM_SYSCOMMAND you can find specific instructions Const WM_SYSCOMMAND = & H112 'this parameter specifies the system let us start the screensaver Const SC_SCREENSAVE = & HF140 & Private Sub Command1_Click () SendMessage Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0End Sub
32. A method of obtaining a local IP address: Winsock control winsockip.localip using two methods: Private Const MAX_IP = 255 Private Type IPINFO dwAddr As Long dwIndex As Long dwMask As Long dwBCastAddr As Long dwReasmSize As Long unused1 As Integer unused2 As Integer End Type Private Type MIB_IPADDRTABLE dEntrys As Long mIPInfo (MAX_IP) As IPINFO End Type Private Type IP_Array mBuffer As MIB_IPADDRTABLE BufferLen As Long End Type Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination _ As Any, Source As Any, ByVal Length As
Long) Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, _ pdwSize As Long, ByVal Sort As Long) As Long Dim strIP As String Private Function ConvertAddressToString (longAddr As Long) As String Dim myByte (3) As Byte Dim Cnt As Long CopyMemory myByte (0), longAddr, 4 For Cnt = 0 To 3 ConvertAddressToString = ConvertAddressToString CStr (myByte (Cnt)) Next Cnt ConvertAddressToString = Left $ (ConvertAddressToString, Len (ConvertAddressToString) - 1) "." End Function Public SUB Start () DIM RET As Long, Tel As Long Dim Bbytes () AS BYTE DIM LISTING AS MIPADDRTABLE IN Error Goto End1 Getdddrtable Byval 0 & Ret, True IF RET <= 0 THEN EXIT SUB Redim Bbytes (0 to Ret - 1 AS BYTE GETIPADDRTABLE BBYTES (0), RET, FALSE COPYMEMORY LISTING.DENTRYS, BBYTES (0), 4 Strip = "" & Listing.DENTRYS & "IP address on your machine." & Vbcrlf Strip = Strip & " ---------------------------------- " & vbcrlf & vbcrlf for tel = 0 to listing.dentrys - 1 CopyMemory Listing.Mipinfo (Tel), Bbytes (4 (tel * len (0)))))))) ) Strip = Strip & "IP address:" Listing.Mipinfo (tel) .dwaddr) & vbcrf next exit suend1: msgbox "error" end subsprivate sub form_load () Start Msgbox Stripend Sub
33. The keyboard keys to control COMBOXPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As LongConst CB_SHOWDROPDOWN = & H14FDim bDrop As BooleanPrivate isDo As BooleanPrivate Sub Combo1_Click () If Not isDo Then isDo = True '<---------- set back state Exit Sub Else: MsgBox "safd" End IfEnd SubPrivate Sub Combo1_DropDown () bDrop = TrueEnd SubPrivate Sub Combo1_KeyDown (KeyCode As Integer, Shift As Integer) If KeyCode = 40 Then isDo = False SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, 1, 0ElseIf KeyCode = 38 Then isDo = False If Combo1.ListIndex = 0 Then If bDrop Then bDrop = False SendMessage Combo1 .hwnd, cb_showdropdown, 0, 0 end if end if Endness (keycode as integer) = Combo1.list (0) Thenisdo = truend (0) Thenisdo = TrueEnd IFEND SUBPRIVATE SUB FORM_LOAD () ISDO = True Combo1.addItem "Abcd" Combo1.addItem "abcd1" combo1.additem "abcd2" combo1.additem "abcd3" end Sub35.vb CRC verification program one calculation calculation is based on The principle of CRC check code is designed. The advantage is that the module code is small, the modification is flexible, and the portability is good. Its disadvantage is that the amount is large. In order to understand, here
Triple data is set, and the polynomial code is A001 (HEX). Place a command button COMMAND1 on the form and add the following code:
Private submmand1_click () DIM CRC () AS BYTE DIM D () AS BYTE 'Terviation Data Redim D (2) AS BYTE D (0) = 123 D (1) = 112 D (2) = 135 CRC = CRC16 ( d) 'Call CRC16 Calculation Function' CRC (0) is a high 'CRC (1) is a low end SUB Note: The lower position of the CRC may be in front, while the high is behind.
Function CRC16 (data () As Byte) As String Dim CRC16Lo As Byte, CRC16Hi As Byte 'CRC register Dim CL As Byte, CH As Byte' polynomial code & HA001 Dim SaveHi As Byte, SaveLo As Byte Dim i As Integer Dim Flag As Integer CRC16LO = & HFF CRC16HI = & HFF CL = & H1 CH = & HA0 for i = 0 to Ubound (data) CRC16LO = CRC16LO XOR DATA (i) 'Each data is different from the CRC register for flag = 0 to 7 Savehi = crc16hi savelo = CRC16LO CRC16HI = CRC16HI / 2 'high-level shift one CRC16LO = CRC16LO / 2' low right shift one IF (Savehi and & H1) = & h1) Then 'If the last one is 1 CRC16LO = CRC16LO OR & H80' Then the low-byte right shifts 1 end if 'otherwise automatic supplement 0 IF (Savelo and & H1) = & h1) Then' If the LSB is 1, it is divided with the multi-model code or CRC16HI = CRC16HI XOR CH CRC16LO = CRC16LO XOR CL end if next flag next I Dim Returndata (1) AS BYTE RETURNDATA (0) = CRC16HI 'CRC High RETURNDATA (1) = CRC16LO' CRC Low CRC16 = RETURNDATA END Function2. The advantages and disadvantages of the watch method will be the opposite of the calculation method. For ease of comparison, all assumptions are exactly the same as the calculation method, and there is a button on the form on the form.
The code portion is also identical to the above. The following is only the write source code for the CRC function.
Private Function CRC16 (data () As Byte) As String Dim CRC16Hi As Byte Dim CRC16Lo As Byte CRC16Hi = & HFF CRC16Lo = & HFF Dim i As Integer Dim iIndex As Long For i = 0 To UBound (data) iIndex = CRC16Lo Xor data (i ) CRC16Lo = CRC16Hi Xor GetCRCLo (iIndex) 'low processing CRC16Hi = GetCRCHi (iIndex)' high processing Next i Dim ReturnData (1) As Byte ReturnData (0) = CRC16Hi 'CRC high ReturnData (1) = CRC16Lo' CRC low CRC16 = Returndata End Function
'CRC Low Sentence Table Function Getcrclo (IND AS Long) AS Byte getcrclo = choose (Ind 1, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H80, & H1, & H0, & H0, & H81, & H0, & H0, & H81, & H40, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1,
& H81, & H40, & H0, & HC1, & H81, & H80, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80,
& H41, & H0, & HC1, & H81, & H80, & H1, & HC0, & H80, & H41, & H0, & H0, & H81, & H0, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H0,
& HC1, & H81, & H80, & H1, & HC0, & H80, & H41, & H1, & H0, & H80, & H41, & H0, & HC1, & H81, & H40, & H0, & HC1, & H81, & H40, & H1, & HC0,
& H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H0, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40, & H0, & HC1, & H81,
& H80, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H0, & H0, & HC1, & H81, & H40, & H1, & H0, & H80, & H41, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80,
& H41, & H1, & H0, & H80, & H81, & H0, & H0, & H81, & H40, & H0, & HC1, & H81, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H0, & HC1,
& H81, & H40, & H1, & HC0, & H80, & H41, & H1, & H0, & H80, & H41, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81,
& H40, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40, & H0, & HC1, & H81, & H40, & H1,
& HC0, & H80, & H81, & H0, & HC1, & H81, & H40, & H1, & HC0, & H80, & H41, & H1, & HC0, & H80, & H41, & H0, & HC1, & H81, & H40) End Function
'CRC High-level VAT FUNCTION GETCRCHI (IND AS Long) AS BYTE GETCRCHI = CHOOSE (Ind 1, & H0, & HC0, & HC1, & H1, & HC3, & H3, & H2, & HC2, & HC6, & H6, & H7, & HC7, & H5, & HC5, & HC4, & H4,
& HCC, & HC, & HD, & HCD, & HF, & HCF, & HCE, & HB, & HC9, & H9, & H8, & HC8, & HD8, & H18, & H19, & HD9, & H1B, & HDB,
& HDA, & H1A, & H1F, & HDE, & HDF, & H1F, & HDD, & H1D, & H1C, & HDC, & H14, & HD4, & HD5, & H15, & HD7, & H17, & H16, & HD6, & HD2, & H12, & H13,
& HD3, & H11, & HD1, & HD0, & H10, & HF0, & H30, & H31, & HF1, & H33, & HF3, & HF2, & H32, & H36, & HF6, & HF7, & H37, & HF5, & H35, & H34, & HF4, & H3C, & HFC, & HFD, & H3D, & HFF, & H3F, & H3A, & HFE, & HFA, & H3A, & H3B, & HFB, & H39, & HF9, & HF8, & H38, & H28, & HE8, & HE9, & H29, & HEB,
& H2B, & H2A, & HEA, & HEE, & H2D, & H2F, & HEF, & H2D, & HED, & HEC, & H2C, & HE4, & H24, & H25, & HE5, & H27, & HE7, & HE6, & H26, & H22, & HE2,
& HE3, & H23, & HE1, & HA0, & H20, & HE0, & HA0, & H60, & H61, & HA1, & H63, & HA3, & HA2, & H62, & H66, & HA6, & HA7, & H67, & HA5, & H65, & H64, & HA4, & H6C, & HAC, & Had, & H6D, & Haf, & H6F, & H6E,
& Hae, & haa, & h6a, & ha9, & hab, & h68, & ha9, & ha8, & hb9, & h78, & hb8, & hb9, & h79, & hb, & h7b, & h7a, & hba, & hbe, & h7e, & h7f, & hbf,
& H7D, & HBD, & HBC, & H7C, & HB4, & H74, & H75, & HB5, & H77, & HB7, & HB6, & H76, & H72, & HB2, & HB3, & H73, & HB1, & H71, & H70, & HB0, & H50,
& H90, & H91, & H51, & H93, & H53, & H52, & H92, & H96, & H56, & H57, & H97, & H55, & H95, & H94, & H54, & H9C, & H5C, & H5D, & H9D, & H5F, & H9F,
& H9E, & H5E, & H5A, & H9A, & H9B, & H5B, & H99, & H59, & H58, & H98, & H88, & H48, & H49, & H89, & H4B, & H8B, & H8A, & H4A, & H4E, & H8E, & H8F, & H4F, & H8D, & H4D, & H4C, & H8C, & H44, & H84, & H85, & H45, & H87, & H47, & H46, & H86, & H82, & H42, & H43, & H83, & H41, & H81, & H80, & H40) end function
36. How to open the optical drive public declare function cddoor lib "Winmm.dll" Alias "McIndstringA" (Byval LPSTRCOMMAND AS STRING, BYVAL LPSTRETURNSTRING
As string, byval ureturnLENGTH AS Long, Byval HWndCallback As Long AS Longcall Cddoor ("Set CDAUDIO DOOR Open", 0, 0, 0) Open the CD-ROM CALL CDDOOR ("SET CDAUDIO DOOR CLOSED", 0, 0, 0) ' Turn off the drive
36. In detecting whether the networking and networking module: Public Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _ Alias "InternetGetConnectedStateExA" _ (ByRef lpdwFlags As Long, _ ByVal lpszConnectionName As String, _ ByVal dwNameLen As Long, _ ByVal dwReserved As Long _) AS Long
Public Enum EIGCInternetConnectionState INTERNET_CONNECTION_MODEM = & H1 & INTERNET_CONNECTION_LAN = & H2 & INTERNET_CONNECTION_PROXY = & H4 & INTERNET_RAS_INSTALLED = & H10 & INTERNET_CONNECTION_OFFLINE = & H20 & INTERNET_CONNECTION_CONFIGURED = & H40 & End Enum
Public Property Get InternetConnected (_ Optional ByRef eConnectionInfo As EIGCInternetConnectionState, _ Optional ByRef sConnectionName As String _) As Boolean Dim dwFlags As Long Dim sNameBuf As String Dim lR As Long Dim iPos As Long sNameBuf = String $ (513, 0) lR = InternetGetConnectedStateEx (dwFlags, sNameBuf, 512, 0 &) eConnectionInfo = dwFlags iPos = InStr (sNameBuf, vbNullChar) If iPos> 0 Then sConnectionName = Left $ (sNameBuf, iPos - 1) ElseIf Not sNameBuf = String $ (513, 0) Then sConnectionName = Snamebuf end if Internetconnected = (lr = 1) End Property Sub Form_Load () 'DETERMINE WHETER WE HAVE A Connection: bconnected = InternetConnected (ER, SNAME)
'The connection state info parameter provides details' about how we connect: If (eR And INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM Then sMsg = sMsg & "Connection uses a modem." & VbCrLf End If If (eR And INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN Then sMsg = sMsg & "Connection uses LAN." & vbCrLf End If If (eR And INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY Then sMsg = sMsg & "Connection is via Proxy." & vbCrLf End If If (eR And INTERNET_CONNECTION_OFFLINE) = INTERNET_CONNECTION_OFFLINE Then sMsg = sMsg & "Connection is Off-line. "& vbCrLf End If If (eR And INTERNET_CONNECTION_CONFIGURED) = INTERNET_CONNECTION_CONFIGURED Then sMsg = sMsg &" Connection is Configured. "& vbCrLf Else sMsg = sMsg &" Connection is Not Configured. "& vbCrLf End If If (eR And Internet_RAS_INSTALLED) = Internet_RAS_INSTALLED THEN SMSG = SMSG & "System Has Ras Installed." & Vbcrlf End IF 'Display the connection name and info: If bConnected Then Text1.Text = "Connected:" & sName & vbCrLf & vbCrLf & sMsg Else Text1.Text = "Not Connected:". & SName & vbCrLf & vbCrLf & sMsg End IfEnd Sub37 give Current version number of Windows
module: Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 'Maintenance string for PSS usageEnd TypeDeclare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As LongDeclare Function GetSystemMetrics lib "user32" (ByVal nIndex As Long) As LongPublic Const SM_CLEANBOOT = 67Public Const SM_DEBUG = 22Public Const SM_SLOWMACHINE = 73Public Const VER_PLATFORM_WIN32s = 0Public Const VER_PLATFORM_WIN32_WINDOWS = 1Public Const VER_PLATFORM_WIN32_NT = 2 form
Private Sub Form_Load () Dim myVer As OSVERSIONINFODim nl As StringDim q As Longnl = Chr (10) & Chr (13) myVer.dwOSVersionInfoSize = 148q & = GetVersionEx (myVer) lblWininfo = "" lblMoreWininfo = "" If myVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then lblWininfo = lblWininfo & "running platform = Windows 95/98" & nlIf myVer.dwPlatformId = VER_PLATFORM_WIN32_NT Then lblWininfo = lblWininfo & "platform = Windows NT" & nllblWininfo = lblWininfo & "Version =" & myVer.dwMajorVersion & "." & myVer .dwMinorVersion & "founded" & (myVer.dwBuildNumber And & HFFFF &) & nllblMoreWininfo = "Windows is now running" If GetSystemMetrics (SM_CLEANBOOT) = 0 Then lblMoreWininfo = lblMoreWininfo & "normal mode" & nlIf GetSystemMetrics (SM_CLEANBOOT) = 1 Then lblMoreWininfo = lblMoreWininfo & "safe mode" & nlIf GetSystemMetrics (SM_CLEANBOOT) = 2 Then lblMoreWininfo = lblMoreWininfo & "LAN safe mode" & nlIf GetSystemMetrics (SM_DEBUG) = True Then lblMoreWininfo = lblMoreWininfo & "Windows Debugging mode in operation" & nlIf GetSystemMetrics (SM_SLOWMACHINE ) = T Rue the lblmorewinfo = lblmorewinInfo & "This PC configuration is too low to efficiently run Windows." & NLEND SUB
38. The keyboard simulation Private Declare Sub keybd_event Lib "user32" _ (ByVal bVk As Byte, _ByVal bScan As Byte, _ByVal dwFlags As Long, _ByVal dwExtraInfo As Long) Private Const VK_LWIN = & H5BPrivate Const KEYEVENTF_KEYUP = & H2Private Const VK_APPS = & H5DPrivate Const VK_PLAY = & HFAPrivate Sub DoAction (Index As Integer) Dim VK_ACTION As LongSelect Case IndexCase 0: 'open Explorer VK_ACTION = & H45Case 1:' Find file VK_ACTION = & H46Case 2: 'minimize all windows VK_ACTION = & H4DCase 3:' operating procedures VK_ACTION = & H52Case 4: 'pop-up WIN menu vk_action = & h5bcase 5:' Transfer computer such as sleep status vk_action = & h5ecase 6: 'Execution Windows help vk_action = & h70nd selectcall keybd_event (vk_lwin, 0, 0) call keybd_event (vk_action, 0, 0, 0) Call keybd_event (vk_lwin, 0, keyeventf_keyup, 0) End Sub39 Delay Function
Public Sub Delay (DelayTime As Single) DIM BEGINTIME AS SINGLINTIME = Timer While Timer 40. A modified form system menu module: Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As LongPublic Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As LongPublic Const WM_SYSCOMMAND = & H112Public Const GWL_WNDPROC = (-4) Public Const MF_STRING = & H0 & Public Const MF_SEPARATOR = & H800 & Public OldWindowProc As Long 'to save the default window function address Public SysMenuHwnd As LongPublic function SubClass1_WndMessage (ByVal hwn d As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long If Msg <> WM_SYSCOMMAND Then SubClass1_WndMessage = CallWindowProc (OldWindowProc, hwnd, Msg, wp, lp) 'If the message is not WM_SYSCOMMAND, it calls the default Window Function Processing Exit Function End If SET CASE WP CASE 2001 CALL MSGBOX ("This program implements the function of modifying the system menu", Vbokonly vbinformation) Case 2003 Call getSystemMenu (Form1.hWnd, true) call setWindowlong (form1.hwnd, GWL_WNDPROC, OldWindowProc) Call Msgbox ("The default system menu has been restored", Vbokonly vbInformation) Case Else SubClass1_WndMessage = CallWindowProc (OldWindowProc, hwnd, Msg, wp, lp) Exit Function End Select SubClass1_WndMessage = True End Function form: Private Sub Form_Load () OldWindowProc = GetWindowLong (Form1.hwnd, GWL_WNDPROC) 'to obtain a window function address Call SetWindowLong (Form1.hwnd, GWL_WNDPROC, AddressOf SubClass1_WndMessage) 'instead of using a window function processing SubClass1_WndMessage message SysMenuHwnd = GetSystemMenu (Form1.hwnd, False) Call AppendMenu (SysMenuHwnd, MF_SEPARATOR, 2000, vbNullString) Call AppendMenu (SysMenuHwnd, MF_STRING, 2001 "About this program (& A)") Call AppendMenu (SysMenuHwnd, MF_SEPARATOR, 2002, vbNullString) Call AppendMenu (SysMenuHwnd, MF_STRING, 2003, "to restore the system menu (& R)") End SubPrivate Sub Form_Unload (Cancel As Integer) If OldWindowProc <> GetWindowLong (Form1.hwnd, GWL_WNDPROC) ThenCall SetWindowLong (Form1.hwnd, GWL_WNDPROC, OldWindowProc) End IfEnd Sub41 how to display large images on a small screen method: a picturebox control, a control image (with picturebox container), Image loaded in Image, a hscroll1, vscroll1 (with Picture Box is a container). Private sub bar1_change () image1.left = -bar1.valueend subprivate sub bar2_change () image1.top = -bar2.valueend sub Picture1.WidthBar2.Max = Image1.Height - - Private Sub Form_Load () Image1.Left = 0Image1.Top = 0bar1.SmallChange = 300Bar2.SmallChange = 300bar1.Max = Image1.Width Picture1.Heightbar1.Min = 0Bar2.Min = 0End Sub Method 2: Using the mouse to move a picture picturebox control, a control image (in picturebox container), the image is loaded in the image Dim ix As IntegerDim iy As IntegerPrivate Sub Form_Load () Image1.Left = 0Image1.Top = 0End SubPrivate Sub Image1_MouseDown ( Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Thenix = Xiy = YEnd IfEnd SubPrivate Sub Image1_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim ipx As IntegerDim ipy As IntegerIf Button = vbLeftButton Thenipx = Image1.Left X - ixipy = Image1.Top Y - iyIf ipx> 0 ThenImage1.Left = 0ElseIf ipx Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (_ lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Public Const GWL_WNDPROC = (-4) Public Const WM_WINDOWPOSCHANGING = & H46Type WINDOWPOS hwnd As Long hWndInsertAfter As Long x As Long y As Long CX As Long CyPublic PrewinProc as long 'and the focus is to pass' out of WM_WindowPosChanging information before the Window repositions, and LParam points to a WindowPOS Structure. Public Function wndproc (ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Dim lwd As Long, hwd As Long If Msg = WM_WINDOWPOSCHANGING Then Dim WPOS As WINDOWPOS CopyMemory WPOS, ByVal lParam, Len (WPOS) IF WPOS.X <0 THEN WPOS.X = 0 CopyMemory Byval LPARAM, WPOS, LEN (WPOS) End if End IF 'Send it to the original Window Procedure WndProc = CallWindowProc (PrewinProc, Hwnd, MSG, WPARAM , lParam) End Function form Sub Form_Load () Dim ret As Long 'window Procedure of recording the original address preWinProc = GetWindowLong (Me.hwnd, GWL_WNDPROC) ret = SetWindowLong (Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End SubPrivate Sub Form_unload (Cancel As Integer) Dim Ret As Long 'Cancels the interception of Message, and makes it only to the original Window Procedure Ret = SetWindowlong (me.hwnd, gwl_wndproc, prewinproc) End Sub 43. Open the specified form Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongConst SW_SHOWNORMAL = 1Private Sub Command1_Click () 'my documents ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1End SubPrivate Sub Command2_Click ()' my computer ShellExecute Me.hwnd, "open" , "Explorer", ":: {20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1nd subprivate submmand3_click () 'Online neighbor Shellexecute me.hwnd, "open", "explorer", ":: {208D2C60 -3AEA-1069-A2D7-08002B30309D} ", vbnullstring, 1nd subprivate submmand4_click () 'recycle bits Shellexecute Me.hwnd," Open "," Explorer "," :: {645F040-5081-101B-9F08-00AA002F954E} " , vbNullString, 1End SubPrivate Sub Command5_Click () 'control panel ShellExecute Me.hwnd, "open", "explorer", ":: {21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1End SubPrivate Sub Command6_Click ()' Open the specified path shellexecu TE me.hwnd, "open", "d: / vb practice example", vbnullstring, vbnullstring, 1nd subsprivate submist7_click () 'volume control shell "SNDVOL32.EXE", VBNORMALFOCUSEND SUB44. Form Subridden Bar Splitter is a PictureBox control. Option ExplicitPrivate Const SPLT_WDTH As Integer = 35Private currSplitPosX As LongDim CTRL_OFFSET As IntegerDim SPLT_COLOUR As LongPrivate Sub Form_Load () CTRL_OFFSET = 5SPLT_COLOUR = & H808080currSplitPosX = & H7FFFFFFFListLeft.AddItem "VB club" ListLeft.AddItem "VB Animation chapter" ListLeft.AddItem "VB Network articles" Listleft.additem "VB Control class" listlex "VB interface class" teXTRight = "often sees two adjacent list boxes on the form, can be pulled with the mouse arbitrarily to change the middle division bar, change the list box size. "End SubPrivate Sub Form_Resize () Dim x1 As IntegerDim x2 As IntegerDim height1 As IntegerDim width1 As IntegerDim width2 As IntegerOn Error Resume Nextheight1 = ScaleHeight - (CTRL_OFFSET * 2) x1 = CTRL_OFFSETwidth1 = ListLeft.Widthx2 = x1 ListLeft.Width SPLT_WDTH - 1width2 = ScaleWidth - x2 - CTRL_OFFSETListLeft.Move x1% - 1, CTRL_OFFSET, width1, height1TextRight.Move x2, CTRL_OFFSET, width2 1, height1Splitter.Move x1 ListLeft.Width - 1, CTRL_OFFSET, SPLT_WDTH, height1End SubPrivate Sub Splitter_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then Splitter.BackColor = SPLT_COLOUR currSplitPosX = CLng (X) Else If currSplitPosX <> & H7FFFFFFF Then Splitter_MouseUp Button, Shift, X, Y currSplitPosX = & H7FFFFFFFEnd IfEnd SubPrivate Sub Splitter_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single) If currSplitPosX & <> & H7FFFFFFF ThenIf CLng (X) <> currSplitPosX ThenSplitter.Move Splitter.Left X, CTRL_OFFSET, SP LT_WDTH, ScaleHeight - (CTRL_OFFSET * 2) currSplitPosX = CLng (X) End IfEnd IfEnd SubPrivate Sub Splitter_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) If currSplitPosX <> & H7FFFFFFF ThenIf CLng (X) <> currSplitPosX Then Splitter.Move Splitter.Left X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2) End IfcurrSplitPosX = & H7FFFFFFFSplitter.BackColor = & H8000000FIf Splitter.Left> 60 And Splitter.Left <(ScaleWidth - 60) ThenListLeft.Width = Splitter .Left - listleft.leftelseif splitter.width = 60lse Listleft.width = Scalewidth - 60nd If Form_ResizeEnd IFEND SUB 44. The tray program module: Option ExplicitPublic preWinProc As LongPublic NewForm As FormPublic NewMenu As MenuPublic Const WM_USER = & H400Public Const WM_LBUTTONUP = & H202Public Const WM_MBUTTONUP = & H208Public Const WM_RBUTTONUP = & H205Public Const TRAY_CALLBACK = (WM_USER 1001 &) Public Const GWL_WNDPROC = (-4) Public const GWL_USERDATA = (-21) Public const NIF_ICON = & H2Public const NIF_TIP = & H4Public const NIM_ADD = & H0Public const NIF_MESSAGE = & H1Public const NIM_MODIFY = & H1Public const NIM_DELETE = & H2Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongDeclare Function Shell_NotifyIcon LIB "shell32.dll" alias "shell_notifyicona" (Byval Dwmessage As Long, LPDATA AS Notifyicondata) As Longpublic Type Notifyicondata cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 64End TypePrivate NOTI As NOTIFYICONDATAPublic Function NewWindone (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As longback dam = tray_callback then if lparam = wm_lbuttonup the 'Click the left button, pop-up window if newform.windowState = vbminimized the _ newform.windowState = NewForm.LastState NewForm.SetFocus Exit Function End If If lParam = WM_RBUTTONUP Then 'Right-click the pop-up menu NewForm.PopupMenu NewMenu Exit Function End If End If NewWindone = CallWindowProc (preWinProc, hwnd, Msg, wParam, lParam) End FunctionPublic Sub AddToTray (frm As Form, mnu As Menu) Set NewForm = frm Set NewMenu = mnu preWinProc = SetWindowLong (frm.hwnd, GWL_WNDPROC, AddressOf NewWindone) With NOTI .uID = 0 .hwnd = frm.hwnd .cbSize = Len (NOTI). hIcon = frm.Icon.Handle .uFlags = NIF_ICON .uCallbackMessage = TRAY_CALLBACK .uFlags = .uFlags Or NIF_MESSAGE .cbSize = Len (NOTI) End With Shell_NotifyIcon NIM_ADD, NOTIEnd Sub 'shielding tray Public Sub RemoveFromTray () With NOTI .uFlags = 0 End with shell_notifyicon nim_delete, noti setwindowlong newform.hwnd, gwl_wndproc, preWinProcend Subpublic Sub Settraytip (TIP As String) with noti .Sztip = tip & vbnullchar .uflags = nif_tip end with shell_notifyicon nim_modify, notiend subodi Public Sub Settrayicon (PIC AS Picture) if Pic.Type <> vbpictypeicon kilon = pic.handle .uflags = nif_icon end with shell_notifyicon nim_modify, NOTIEND SUB form Private Sub Form_Load () AddtTTRAY ME, TRAY Settraytip "Tray Demo" End Subprivate Sub Form_Unload (Cancel AS Integer) RemoveFromtrayEnd Sub Add Class 45.led numerical display module: (name attribute mcLCD) Option ExplicitPrivate Type CoordinateX As IntegerY As IntegerEnd TypeDim BasePoint As CoordinateDim SegWidth As IntegerDim SegHeight As IntegerDim p As PictureBoxProperty Let BackColor (Color As Long) p.BackColor = ColorEnd PropertyPrivate Sub DrawNumber (Number As Integer) Select Case NumberCase 0DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4) DrawSegment (5): DrawSegment (6) Case 1DrawSegment (2): DrawSegment (3) Case 2DrawSegment ( 1): DrawSegment (7): DrawSegment (5) DrawSegment (4) Case 3Drawsegment (1): DrawSegment (2): DrawSegment (7): DrawSegment (4) DrawSegment (4) Case 4Drawsegment (2) : DrawSegment (7): DrawSegment (6) Case 5drawsegment (1): DrawSegment (6): DrawSegment (7): DrawSegment (3) DrawSegment (4) Case 6drawSegment (1): DrawSegment (6): DrawSegment (3) DrawSegment (4): DrawSegment (5) Case 7drawSegment (1): DrawSegment (2) DrawSegment (3) Case 8DrawSegment (1): DrawSegment (2): DrawSegm Ent (3): DrawSegment (4) DrawSegment (5): DrawSegment (6): DrawSegment (7) Case 9DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4) DrawSegment (6): DrawSegment (6): DrawSegment 7) End selected subprivate sub drawsegment (segnum as integer) '1' ___ '| |' 6 | | 2 '| -7- |' 5 | | 3 '| ___ |' '4' draws seven-stage digital tube Seven components Select Case segnumcase 1p.Line (Basepoint.x 1, Basepoint.y) - (Basepoint.x segwidth - 1, basepoint.y) p.Line (basepoint.x 2, basepoint.y 1 ) - (Basepoint.x segwidth - 2, basepoint.y 1) p.Line (Basepoint.x 3, basepoint.x 2) - (Basepoint.x segwidth - 3, basepoint.y 2) Case 2p.Line (basepoint.x SegWidth - 1, BasePoint.y 1) - (Basepoint.x segwidth - 1, basepoint.y (segheight / 2) - 1) p.Line (Basepoint.x segwidth - 2, basepoint.y 2) - (Basepoint.x segwidth - 2, basepoint.y (segheight / 2)) p.Line (Basepoint.x segwidth - 3, basepoint.y 3) - (Basepoint.x segwidth - 3, basepoint. Y (segheight / 2) - 1) Case 3p.Line (Basepoint.x segwidth - 1, basepoint.y 2) - (Basepoint.x segwidth - 1, basepoint.y segheight ) P.Line (BasePoint.x segwidth - 2, basepoint.y (segheight / 2) 1) - (Basepoint.x segwidth - 2, basepoint.y segheight - 1) p.Line (basepoint.x SegWidth - 3, Basepoint.y (Segheight / 2) 2) - (Basepoint.x segwidth - 3, basepoint.y segheight - 2) case 4p.line (basepoint.x 3, basepoint.y Segheight - 2) - (Basepoint.x SegWidth - 3, Basepoint.Y SegHeight - 2) P.Line (Basepoint.x 2, Basepoint.Y SegHeight - 1) - (Basepoint.x segwidth - 2, Basepoint.y segheight - 1) p.Line (basepoint.x 1, basepoint.y segheight) - (Basepoint.x SegWidth - 1, BasePoint.y Segheight) Case 5p.Line (Basepoint.x, Basepoint.y (SegHeight / 2) 2) - (Basepoint.x, BasePoint.y SegHeight) p.Line (basepoint.x 1, BasePoint.y 1) - (Basepoint.x 1, Basepoint.Y SegHeight - 1) P.Line (Basepoint.x 2, Basepoint.Y (Segheight / 2) 2) - (Basepoint.x 2, Basepoint.y SegHeight - 2) Case 6p.Line (Basepoint.x, Basepoint.y 1) - (Basepoint.x, Basepoint.y (SegHeight / 2) - 1) p.Line (basepoint.x 1, basepoint.y 2) - (BasePoint.x 1, BasePoint.y (Segheight / 2)) P.Line (Basepoint.x 2, Basepoint.y 3) - (Basepoint.x 2, Basepoint.y (Segheight / 2) - 1) Case 7P.Line (Basepoint.x 3, Basepoint.y (Segheight / 2) - 1) - (Basepoint.x SegWidth - 3, Basepoint.Y (SegHeight / 2) - 1) P.Line (Basepoint.x 2, Basepoint.Y (Segheight / 2)) - (Basepoint.x segwidth - 2, basepoint.y (segheight / 2)) p.Line (basepoint.x 3, basepoint.y (segheight / 2) 1) (BasePoint.X SegWidth - 3, BasePoint.Y (SegHeight / 2) 1) End SelectEnd SubPublic Property Let Caption (ByVal Value As String) Dim OrigX As IntegerOrigX = BasePoint.Xp.ClsWhile Value <> "" If Left $ (Value, 1) <> ":" And Left $ (Value, 1) <> "." "Thend $ (Value, 1))) Basepoint.x = basepoint.x segwidth 3ELSEIF LEFT $ (Value, 1) = "." "THENP.LINE (SEGWIDTH / 2) - 4, BasePoint.y (SegHeight / 2) 6) - (Basepoint.x (segwidth / 2), Basepoint .Y (segheight / 2) 9), bfbasepoint.x = basepoint.x segwidthelsep.Line (baspoint.x (segwidth / 2) - 4, ba Sepoint.y (Segheight / 2) - 6) - (Basepoint.x (segwidth / 2), Basepoint.Y (Segheight / 2) - 3), BFP.LINE (Basepoint.x (segwidth / 2 ) - 4, BasePoint.y 4) - (Basepoint.x (segwidth / 2), Basepoint.y (Segheight / 2) 7), BfbasePoint.x = basepoint.x SegWidThend IFEnd ifValue = Right $ (Value, Len (Value) - 1) WendbasePoint.x = Origxnd PropertyProperty Let Forecolor (Color As Long) P.foreColor = Colorend Property Public Sub NewLCD (PBox As PictureBox) Set p = PBoxp.ScaleMode = 3 'pixelp.AutoRedraw = TrueBasePoint.X = 2BasePoint.Y = 2SegHeight = p.ScaleHeight - 6SegWidth = (SegHeight / 2) 2End Sub Form: Option ExplicitDim lcdTest1 as New mcLCDPrivate Sub Form_Load () () lcdTest1.Caption = TimeEnd Sub48. the menu portion in the form's rightmost segment lcdTest1.NewLCD picture1End SubPrivate Sub Timer1_Timer (such as help, etc.) in the editor menu to be placed in the The top of the menu is added to the menu of the top right segment, and remove the hook before the Visable property. Private Type MENUITEMINFO '....... please add their own ah End TypePrivate Const MFT_RIGHTJUSTIFY = & H4000'API function declaration Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As LongPrivate Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As LongPrivate Declare Function DrawMenuBar Lib "User 32" (Byval HWnd As Long) AS LongPrivate Declare Function GetMenu LIB "User32" (BYVAL HWND AS Long) AS Long 'Changes to Menu Settings in Form Loading (Other Procedures) Menu Settings PRIVATE SUB FORM_LOAD () Dim my_menuItemInfo As MENUITEMINFODim return_value As Longmy_menuItemInfo.cbSize = 44my_menuItemInfo.fMask = 16my_menuItemInfo.cch = 128my_menuItemInfo.dwTypeData = Space $ (128) return_value = GetMenuItemInfo (GetMenu (Me.hwnd), 2, 1, my_menuItemInfo) '2 where Please pay according to your own situation, to normalize the number of menus on the left end MY_MENUIIIIIIIITEFO.FTYPE = MFT_R IGHTJUSTIFYRETURN_VALUE = SetMenuiteminfo (GetMenu (Me.hwnd), 2, 1, My_MENUITEMINFO) End Sub 46.List is prompted for each line '--------------------- by Chen Rui ------------- ----------------- If you want to post your article on the Internet or BBS, please inform me (no notice, don't know if it is not criminal, huh, this program demonstrates how Plus a different prompt row in each list of List Box, run the program, when the mouse moves to anyone, the pop-up Tooltip will prompt the full content of the line 'Option ExplicitPrivate Declare Function SendMessage Lib "User32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ lParam As Any) As LongPrivate Const LB_ITEMFROMPOINT = & H1A9Private Sub Form_Load () With List1 .AddItem "Chen Rui ChenReee@Netaddress.com" .AddItem "Chen Rui Reee-Chen@Netaddress.com" .AddItem "Chen Rui Chenrui@hotmail.com" End WithEnd SubPrivate Sub List1_MouseMove (Button As Integer, Shift As Integer, _X As Single, Y As Single) 'present related tip message Dim LXPoint As Long Dim Lypoint As Long Dim Lindex As long if button = 0 Then 'If no button is pressed LXPoint = ClNG (x / screen.twipsperpixelx) lypoint = clng (Y / screen.twipsperpixely) with list1' Get the current cursor The screen position determines the title position LINDEX = S EndMessage (.hwnd, lb_itemfrompoint, 0, _ byval ((Lypoint * 65536) lxPoint)) "Show prompt line or clear prompt line if (lindex> = 0) and (lindex <= .ListCount) Then .tooltiptext = .list (LINDEX) Else .tooltiptext = "" "End if End with end ifend sub 47. Place some menus (such as help, etc.) in the form of the menu (such as help, etc.) in the menu editor, add a title to the menu to be placed in the top right paragraph, and remove the Visable property before the hook. Private Type MENUITEMINFO '....... please add their own ah End TypePrivate Const MFT_RIGHTJUSTIFY = & H4000'API function declaration Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As LongPrivate Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As LongPrivate Declare Function DrawMenuBar Lib "User 32" (Byval HWnd As Long) AS LongPrivate Declare Function GetMenu LIB "User32" (BYVAL HWND AS Long) AS Long 'Changes to Menu Settings in Form Loading (Other Procedures) Menu Settings PRIVATE SUB FORM_LOAD () Dim my_menuItemInfo As MENUITEMINFODim return_value As Longmy_menuItemInfo.cbSize = 44my_menuItemInfo.fMask = 16my_menuItemInfo.cch = 128my_menuItemInfo.dwTypeData = Space $ (128) return_value = GetMenuItemInfo (GetMenu (Me.hwnd), 2, 1, my_menuItemInfo) '2 where Please pay according to your own situation, to normalize the number of menus on the left end MY_MENUIIIIIIIITEFO.FTYPE = MFT_R IGHTJUSTIFYRETURN_VALUE = SetMenuiteminfo (GetMenu (Me.hwnd), 2, 1, My_MENUITEMINFO) End Sub 48. change the screen resolution Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As LongPrivate Const CCHDEVICENAME = 32Private Const CCHFORMNAME = 32Private Const ENUM_CURRENT_SETTINGS = 1Private Type DEVMODE ....... .. (please add on their own) End TypePrivate Declare Function ChangeDisplaySettings Lib "user32" _ Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As LongPrivate Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _ (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As LongPrivate Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As LongPrivate Const SM_CXSCREEN = 0Private Const SM_CYSCREEN = 1Dim pNewMode As DEVMODEDim pOldMode As LongDim nOrgWidth As Integer, nOrgHeight As Integer 'Sets the execution function of the display resolution Private function setDisplayMode (Width as integer) _ as long', freq as long, as long, error goto errorhandler Co nst DM_PELSWIDTH = & H80000 Const DM_PELSHEIGHT = & H100000 Const DM_BITSPERPEL = & H40000 Const DM_DISPLAYFLAGS = & H200000 Const DM_DISPLAYFREQUENCY = & H400000 With pNewMode .dmSize = Len (pNewMode) If Color = 0 Then 'Color = 0 without change screen colors .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Else .dmfields = DM_BITSPELDS = DM_PELSWIDTH OR DM_PELSHEIGHT End if .dmpelswidth = width .dmpelsheight = Height if color <> 0 Then .dmbitsperpel = color end if End with PoldMode = lstrcpy (pNewMode, pNewMode) SetDisplayMode = ChangeDisplaySettings (pOldMode, 1) Exit FunctionErrorHandler: MsgBox Err.DescriptionEnd FunctionPrivate Sub Command1_Click () Dim nWidth As Integer, nHeight As Integer, nColor As Integer Select Case Combo1.ListIndex Case 0 nWidth = 640: nHeight = 480: ncolor = 16 '640 * 480 * 16 位 真, 256 color ncolor _ = 8,16 color ncolor = 4, ncolor = 0 means no change color case 1 nwidth = 640: NHEight = 480: ncolor = 24 case 2 nwidth = 640: nheight = 480: ncolor = 32 case 3 nwidth = 800: NHEight = 600: ncolor = 16 case 4 nwidth = 800: NHEight = 600: ncolor = 24 case 5 nwidth = 800: NHEight = 600: ncolor = 32 case 6 nwidth = 1024: nheight = 768: ncolor = 16 case 7 nwidth = 1024: nheight = 768: ncolor = 24 case 8 nwidth = 1024: nHEight = 768: ncolor = 32 case other nwidth = 800: NHEight = 600: NCO LOR = 16 End Select Call SetDisplayMode (NWidth, NHEIGHT, NCOLOR) 'Note that the display mode not supported by the system is not' Can be selected, otherwise it is ready to restart. * 16 Time Color "Combo1.Additem" 640 * 480 * 24-bit color "combo1.additem" 640 * 480 * 32-bit color "combo1.additem" 800 * 600 * 16-bit color "combo1.additem" 800 * 600 * 24 Time Color "Combo1.Additem" 800 * 600 * 32-bit color "Combo1.additem" 1024 * 768 * 16-bit true color "comb1.additem" 1024 * 768 * 24-bit color "Combo1.Additem "1024 * 768 * 32-bit color" Combo1.Text = Combo1.List (0) nOrgWidth = GetDisplayWidth nOrgHeight = GetDisplayHeight 'nOrgWidth = GetSystemMetrics (SM_CXSCREEN)' get the initial screen size of the two kinds of methods can be 'nOrgHeight = GetSystemMetrics (SM_CYSCREEN) End SubPrivate Function GetDisplayWidth () As Integer GetDisplayWidth = screen.Width / Screen.TwipsPerPixelXEnd FunctionPrivate Function GetDisplayHeight () As Integer GetDisplayHeight = screen.Height / Screen.TwipsPerPixelYEnd FunctionPrivate Sub RestoreDisplayMode () Call SetDisplayMode (nOrgWidth, nOrgHeight, 0) End SubPrivate Sub Form_Unload (Cancel As Integer) RestoreDisplayModeEnd Sub49 each Input-conversion Function Bin2Dec (InputData As String) AS Double 'binary transition into decimal DIM DECOUT AS DOUBLE: DIM I AS INTEGER: DIM JON AS DOUBLE: DIM JONE AS STRINBIN = LEN (InputData) confirms whether it is a binary number for i = 1 to lenbin Jone = MID (InputData, I, 1) IF JONE <> "0" and JONE <> "1" THEN MSGBOX "Not a binary number", vbcritical exit function end ifxTIDECOUT = 0for i = LEN (InputData ) TO 1 Step -1 IF (Inpu TDATA, I, 1) = "1" THEN DECOUT = DECOUT 2 ^ (Len (InputData) - i) end ifnext ibin2dec = DECoutens function Function Dec2Bin (InputData As Double) As String 'decimal converted to binary Dim Quot As Double: Dim Remainder As Double: Dim BinOut As String: Dim I As IntegerDim NewVal As Double: Dim TempString As String: Dim TempVal As DoubleDim BinTemp As String: Dim BinTemp1 as String: Dim PosDot as IntegerDim Temp2 as String 'checks whether the decimal point if InStr (1, CStr (InputData), ".") Then MsgBox "Only Whole Numbers can be converted", vbCritical GoTo edsEnd IfBinOut = " "Newval = INPUTDATADOAGAIN: 'Start calculation newval = (newval / 2)' If there is a remainder IF INSTR (1, CSTR (NewVal),". ") THEN Binout = Binout " 1 "gets the remaining newval = format (NewVal, "# 0") newval = (NewVal - 1) if newval <1 Then Goto Doneit End Ifelse binout = binout "0" if newval <1 Then Goto Doneit End IFEND IFOTO DOAGAINDONEIT: BINTEMP = "" reversal results for i = Len (binout) to 1 step -1 bintemp1 = mid (binout, i, 1) bintemp = bintemp bintemp1next ibinout = bintemp 'output result dec2bin = binouteds: End Function Function Bin2Hex (InputData As String) As String 'into a binary hexadecimal Dim I As Integer: Dim LenBin As Integer: Dim JOne As String: Dim NumBlocks As IntegerDim FullBin As String: Dim HexOut As String: Dim TempBinBlock As StringDim TempHex As stringlenbin = len (inputdata) 'confirmed whether it is a binary number for i = 1 to lenbin jone = MID (InputData, I, 1) IF JONE <> "0" and Jone <> "1" THEN MSGBOX "not a binary number Number ", vbcritical exit function end ifnext i 'set binary variable Fullbin = inputdata' If this value is less than 4, then supplement 0iF lenbin <4 dam =" 0 " fullbin elseif lenbin = 2 Then Fullbin = "00" fullBin ElseIf LenBin = 1 Then fullBin = "000" fullBin ElseIf LenBin = 0 Then MsgBox "Nothing Given ..", vbCritical Exit Function End If NumBlocks = 1 GoTo DoBlocksEnd IfIf LenBin = 4 Then NumBlocks = 1 GoTo DoBlocksEnd IfIf LenBin> 4 ThenDim TempHold As CurrencyDim TempDiv As CurrencyDim AfterDot As IntegerDim Pos As IntegerTempHold = Len (InputData) TempDiv = (TempHold / 4) Pos = InStr (1, CStr (TempDiv), ".") I f Pos = 0 Then NumBlocks = TempDiv GoTo DoBlocksEnd IfAfterDot = Mid (CStr (TempDiv), (Pos 1)) If AfterDot = 25 Then FullBin = "000" FullBin NumBlocks = (Len (FullBin) / 4) ElseIf AfterDot = 5 THEN FULLBIN = "00" Fullbin Numblocks = (Fullbin) / 4) Elseif afterdot = 75 Then Fullbin = "0" Fullbin Numblocks = (Len (Fullbin) / 4) Else Msgbox "BIG TIME Screw Up" Big Time Screw Upped, Wahhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhi "For i = 1 to len (fullbin) Step 4 Tempbinblock = MID (Fullbin, I, 4) if Tempbinbinblock =" 0000 "THEN Hexout = HEXOUT " 0 "elseif tempinblock =" 0001 "THEN Hexout = HEXOUT " 1 " ElseIf TempBinBlock = "0010" Then HexOut = HexOut "2" ElseIf TempBinBlock = "0011" Then HexOut = HexOut "3" ElseIf TempBinBlock = "0100" Then HexOut = HexOut "4" ElseIf TempBinBlock = "0101" Then HexOut = HexOut "5" ElseIf TempBinBlock = "0110" Then HexOut = HexOut "6" ElseIf TempBinBlock = "0111" Then HexOut = HexOut "7" ElseIf TempBinBlock = "1000" Then HexOut = HexOut "8" ElseIf TempBinBlock = "1001" Then HexOut = HexOut "9" ElseIf TempBinBlock = "1010" Then HexOut = HexOut "A" ElseIf TempBinBlock = "1011" Then HexOut = HexOut "B" ElseIf TempBinBlock = "1100" Then HexOut = HexOut "C" ElseIf TempBinBlock = "1101" Then HexOut = HexOut "D" ElseIf TempBinBlock = "1110" Then HexOut = HexOut "E" ElseIf TempBinBlock = "1111" Then HexOut = HexOut "F" End IfNext IBin2Hex = HEXOUTEDS: END FUNC Tion Function Hex2Bin (InputData As String) As StringDim I As Integer: Dim BinOut As String: Dim Lenhex As IntegerInputData = UCase (InputData) Lenhex = Len (InputData) For I = 1 To LenhexIf IsNumeric (Mid (InputData, I, 1)) Then Goto Numokelseif Mid (InputData, I, 1) = "A" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "B" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "C" THEN GOTO NUMOKELSEIF MID ( InputData, I, 1) = "D" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "E" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "f" the Goto Numokelse Msgbox "Number Given Is Not in IN HEX format ", vbcritical exit functionend ifnumok: Next ibinout =" "for i = 1 to Lenhexif Mid (InputData, I, 1) =" 0 "THEN BINOUT = Binout " 0000 "Elseif Mid (InputData, I, 1) = "1" THEN BINOUT = Binout "0001" elseif Mid (InputData, I, 1) = "2" THEN BINOUT = Binout "0010" Elseif Mid (InputData, I, 1) = "3" THEN Binout = Binout "0011" Elseif Mid (InputData, I, 1) = "4" THEN BINOUT = Binout "0100" Elseif Mid (InputData, I, 1) = "5" Then binout = binout "0101" Elseif Mid (InputData, I, 1) = "6" THEN BINOUT = Binout "0110" Elseif MID (InputData, I, 1) = "7" THEN Binout = Binout "0111" Elseif Mid (InputData, I, 1) = "8" THEN BINOUT = Binout "1000" Elseif Mid (InputData, I, 1) = "9" THEN BINOUT = Binout "1001" Elseif Mid (InputData, I, 1 ) = "A" Then binout = binout "1010" Elseif Mid (InputData, I, 1) = "B" THEN BINOUT = Binout "1011" Elseif Mid (InputData, I, 1) = "C" THEN BINOUT = Binout "1100" Elseif Mid (InputData, I, 1) = "D" THEN BINOUT = Binout "1101" Elseif MID (InputData, I, 1) = "e" Then binout = binout "1110" Elseif Mid (InputData, I, 1) = "f" Then binout = binout "1111" else msgbox "something is screwed up, wahhhhhhhhhh", vbcriticalend ifnext hex2bin = binouteds: End Function Function Hex2Dec (InputData As String) As DoubleDim I As Integer: Dim DecOut As Double: Dim Lenhex As Integer: Dim HexStep As DoubleDecOut = 0InputData = UCase (InputData) Lenhex = Len (InputData) For I = 1 To LenhexIf IsNumeric (Mid ( InputData, I, 1)) THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "a" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = "B" THEN GOTO NUMOKELSEIF MID (InputData, I, 1) = " C "Then Goto Numokelseif Mid (InputData, I, 1) =" D "THEN GOTO NUMOKELSEIF MID (InputData, I, 1) =" E "THEN GOTO NUMOKELSEIF MID (InputData, I, 1) =" f "Then Goto Numokelse MsgBox "Number given is not in Hex format", vbCritical Exit FunctionEnd IfNumOk: Next IHexStep = 0For I = Lenhex To 1 Step -1HexStep = HexStep * 16If HexStep = 0 Then HexStep = 1End If If Mid (InputData, I, 1) = "0" THEN DECOUT = DECOUT (0 * Hexstep) Elseif MID (InputData, I, 1) = "1" THEN DECOUT = DECOUT (1 * Hexstep) Elseif Mid (InputData, I, 1) = "2" THEN DECOUT = DECOUT (2 * hexstep) Elseif MID (InputData, i, 1) = "3" THEN DECOUT = DECOUT (3 * HEXSTEP) Elseif Mid (InputData, I, 1) = "4" THEN DECOUT = DECOUT (4 * HexStep) Elseif Mid (InputData, I, 1) = "5" THEN DECOUT = DECOUT (5 * hexstep) Elseif Mid (InputData, I, 1) = "6" THEN DECOUT = DECOUT (6 * hexstep) Elseif Mid (InputData, I, 1) = "7" THEN DECOUT = DECOUT (7 * hexstep) Elseif Mid (InputData, I, 1) = "8" THEN DECOUT = DECOUT (8 * HEXSTEP) Elseif MID (InputData, I, 1) = "9" Then Decout = decOut (9 * hexstep) Elseif Mid (InputData, I, 1) = "a" Then Decout = DECOUT (10 * hexstep) Elseif Mid (InputData, I, 1) = "b" Then Decout = Decout (11 * hexstep) Elseif Mid (InputData, I, 1) = "c" Then Decout = DECOUT (12 * HexStep) Elseif Mid (InputData, I, 1) = "D" THEN DECOUT = DECOUT (13 * HEXSTEP) ELSEIF MID (InputData, I, 1) = "e" Then Decout = DECOUT (14 * hexstep) Elseif Mid (InputData, I, 1) = "f" Then decate = decOut (15 * hexstep) Else Msgbox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical End IfNext IHex2Dec = DecOuteds: End Function invocation: Private Sub cmdbin2hex_Click () txthex.Text = Bin2Hex (txtbinary.Text) End SubPrivate Sub cmddec2bin_Click () If IsNumeric (txtdec2bin.Text) Then txtdec2bin2.Text = Dec2Bin (txtdec2bin.Text) End IfEnd SubPrivate Sub cmdDecHex_Click () If IsNumeric (txtDecimal.Text) Then txtdechex.Text = Hex (CDbl (txtDecimal.Text)) Else MsgBox "Not a Number.", vbCriticalEnd IfEnd SubPrivate Sub cmdhex2bin_click () txtbinary2 .Text = hex2bin (txtHex2.text) end subsprivate subdhexdec_click () txtDec2.text = cstr (HEX2DEC (TXTHEXDEC.TEXT) End Sub 50. The left and right control channels Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal _ lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As _ Long, ByVal hwndCallback As Long) As LongPrivate Sub Command1_Click () PlaySound "F: / Music / Incubus / Shuimu - Goodbye" MP3 "End Subfunction Plays (Byval FileName As String) AS Boolean Dim Cmd As String, Exname As String Exname = Right (FileName, 3) McIndstring" Close "Close "& Exname, 0, 0, 0 cmd =" open "& filename &" alias "& exname mciSendstring cmd, 0, 0, 0 Playsound = McIndstring (" Play "& Exname, 0, 0, 0) end functionprivate subs circan2_click () Static flag as boolean 'Set the left switch MCISENDSTRING "Set All Audio All" & Iif (Flag, "On", "OFF"), 0, 0, 0 if flag = false kiln command2.caption = "left sound Road (Off) "Else Command2.caption =" left channel (open) end if flag = NOT flagend subsprivate submmand3_click () static flag as boolean 'Setting Right Switch McIndstring "Set All Audio All Audio ALL "& IIF (Flag," on "," OFF "), 0, 0, 0 if flag = false kilocad3.caption =" Right channel (Off) "else command3.caption =" right channel (open) " End if flag = not flagend subprivate submmand4_click () 'Settings MP3 Device Volume: 0-1000, 500 Indicates the volume McSendString "Set MP3 Audio Volume to 500", 0, 0, 0 End Sub51. Using VB to generate screen changes Dust effect (turn, other people's code) Private Type RectLEFT AS Longtop As LongRight As longbottom as LONGEND TYPE Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPrivate Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As LongPrivate Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As LongPrivate bybits (1 To 16) As BytePrivate hBitmap As Long, hBrush As LongPrivate HDESKTOPWND As Long PRIVATE SUB COMMAND1_CLICK () DIM ROP AS Long, RES AS Longdim HDC5 As Long, Width5 As Long, Height5 As Long HDC5 = getdc (0) width5 = screen.width / screen.twipsperpixelxheight5 = Screen.height / Screen.twipsPixely ROP = & HA000C9Call selectobject (HDC5, Hbrush) Res = Patblt (HDC5, 0, 0, Width5, Height5, ROP) Call deleteObject (Hbrush) Res = releasedc (0, hdc5) End Sub PRIVATE SUB Command2_Click () DIM AA As Long AA = INVALIDATERECT (0, 0, 1) End Sub Private Sub Form_Load () Dim Arydim i as longary = array (& H55, & H0, & HAA, & H0, _ & H55, & H0, & HAA, & H0, _ & H55, & H0, & HAA, & H0, _ & H55, & H0, & HAA, & H0) for i = 1 to 16bybits (i) = ary (i - 1) Next hbitmap = createbitmap (8, 8, 1, 1, bybits (1)) HBrush = createpatternbrush (hbitmap) Picture1.ForeColor = RGB (0, 0, 0) Picture1.backcolor = RGB (255, 255, 255) Picture1.ScaleMode = 3End Sub52. mouse defined in a certain area Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd Type Declare Function ClipCursor Lib "user32" (lpRect As Any) As LongDeclare Function ShowCursor Lib "user32" (ByVal bShow As Long) As LongDeclare Function SetCursorPos Lib "user32" (ByVal x As Long, _ ByVal y As Long) As LongDeclare Function GetWindowRect Lib "user32" _ (ByVal hwnd As Long, lpRect As Rect) As long 'setting MOUSE Moiled Wai is in a Control item PUBLIC FUND TOLOCKCURSOR (BYVAL CTLHWND AS Long) AS Booleandim Rect5 As Rectdim Res as LonggetWindowRect CTLHWN D, Rect5 'gets Window four corners setCursorpos (Rect5.top Rect5.Bottom) / 2 (Rect5.LEFT Rect5.right) / 2 res = clipcursor (rect5) if res = 1 TolyLockcursor = TrueElse TOLOCKCURSOR = FalseEnd IfEnd Function 'is set Mouse movement around a screen Public Sub toUnLockCursor () Dim rscreen as RECTrscreen.Top = 0rscreen.Left = 0rscreen.Right = screen.Width / Screen.TwipsPerPixelXrscreen.Bottom = screen.Height / Screen.TwipsPerPixelYClipCursor Rscreenend Sub Private Sub Command1_Click () Call TOLOCKCURSOR (ME.HWND) 'Change me.hwnd to the handle of other controls, the mouse is limited to this area. . End SubPrivate Sub Command2_Click () Call toUnLockCursorEnd Sub53 get a screen resolution method: Debug.Print Screen.Width / Screen.TwipsPerPixelXDebug.Print Screen.Height / Screen.TwipsPerPixelY Method Two: Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPublic Sub DeviceInfo (DisplayX As Integer, DisplayY As Integer, DisplayColor As Integer) Dim hdesktopwndDim hdccapsDim lblRes As StringDim DisplayBitsDim DisplayPlanesDim RetValhdccaps = GetDC (hdesktopwnd) DisplayBits = GetDeviceCaps (hdccaps, 12) DisplayPlanes = GetDeviceCaps (hdccaps, 14) DisplayX = GetDeviceCaps (hdccaps, 8) DisplayY = GetDeviceCaps (hdccaps, 10) RetVal = ReleaseDC (hdesktopwnd, hdccaps) Select Case DisplayBitsCase 1If DisplayPlanes = 1 ThenDisplayColor = 1ElseIf DisplayPlanes = 4 Then DisplayColor = 4 Else DisplayColor = 0End IfCase 8Displ Aycolor = 8case 16displayColor = 16case 24DisplayColor = 24case 32displayColor = 32case elsedisplayColor = 0 'unknown color End SelectensEnd Sub Private Sub Command1_Click () DIM X AS INTEGER, Y AS Integer, Color As IntegerDeviceInfo X, Y, ColormSgbox "Resolution" & X & "X" & Yend Sub 54. dynamically add menu Const MF_CHECKED = & H8 & Const MF_APPEND = & H100 & Const TPM_LEFTALIGN = & H0 & Const MF_DISABLED = & H2 & Const MF_GRAYED = & H1 & Const MF_SEPARATOR = & H800 & Const MF_STRING = & H0 & Const TPM_RETURNCMD = & H100 & Const TPM_RIGHTBUTTON = & H2 & Private Type POINTAPI x As Long y As LongEnd TypePrivate Declare Function CreatePopupMenu Lib "user32" ( ) As LongPrivate Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal HWnd As Long, ByVal lptpm As Any) As LongPrivate Declare Function AppendMenu Lib "user32" alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As LongPrivate Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As LongPrivate Declare Function GetCursorPos Lib "user32" ( LPPOINT AS POINTAPI) AS Longdim Hmenu As LongPrivate Sub Form_Mouseup (Button As INTEGER, SHIFT AS INTEGER, X As Single, Y As Single) ifeton = 2 THEN Dim Pt As POINTAPI Dim ret As Long hMenu = CreatePopupMenu () AppendMenu hMenu, MF_STRING, 1, "Hello!" AppendMenu hMenu, MF_GRAYED Or MF_DISABLED, 2, "Testing ..." AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0 & AppendMenu hMenu , MF_CHECKED, 4, "TrackPopupMenu" GetCursorPos Pt ret = TrackPopupMenuEx (hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, Pt.x, Pt.y, Me.HWnd, ByVal 0 &) DestroyMenu hMenu Select Case ret Case 1 MsgBox " ! Hello "Case 4 MsgBox" TrackPopupMenu "End Select End IfEnd Sub55 use API functions timer function block:. Option ExplicitPublic lTimerId As LongPrivate Declare Function SetTimer Lib" user32 "(ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As LongPrivate Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As LongPrivate Sub TimerProc (ByVal lHwnd As Long, ByVal lMsg As Long, ByVal lTimerId As Long, ByVal lTime As Long) Static i As Long Form1.Label1.Caption = i i = i 1End SubPublic Sub StartTimer (lMinute As Long) lTimerId = SetTimer (0, 0, lMinute, AddressOf TimerProc) End SubPublic Function StopTimer (lTimerId As Long) As Long StopTimer = KillTimer (0, LTIMERID) End Function In the form: Private sub flow_load () StartTimer 1000und SUB Private Sub Form_Unload (Cancel As Integer) Stoptimer Ltimeridend Sub 56. Create a GUID 'GUID is the abbreviation of globally unique Identifier. From a special algorithm to generate these 128-bit numbers, guarantees that there is certainly available, but there is too much number, so the algorithm is particularly The number of repetitions, this situation will not be seen in your life. ActiveX control has a Guid for mutual distinguish. How do you use GUID in your own program? For example, each entry for a database is required At the time of a unique key. The following code will give you an answer: Option ExplicitPrivate Type GUID Data1 As Long Data2 As Long Data3 As Long Data4 (8) As ByteEnd TypePrivate Declare Function CoCreateGuid Lib "ole32.dll" (pguid As GUID) As LongPrivate Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long Private Function GUIDGen () As String Dim uGUID As GUID Dim sGUID As String Dim bGUID () As Byte Dim lLen As Long Dim RetVal As Long lLen = 40 bGUID = String (lLen, 0) CocreateGuid UGUID 'converts the structure into a displayable string RetVal = stringFromGuid2 (UGUID, Varptr (bguid (0)), LLEN SGUID = BGUID IF (ASC (MID $ (SGUID, Retval, 1)) = 0 ) THEN RETVAL = RETVAL - 1 Guidgen = Left $ (sguid, retval) End function private subs cmdguid_click () txtGuid.text = guidgenend sub 57. Create a gradient form Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As LongPrivate Declare Function FillRect lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function DeleteObject lib "gdi32" (ByVal hObject As Long) As Long Private Type RECT left As Long top As Long right As Long bottom As Long End TypePrivate Sub Form_Paint () Dim Color As Long Dim hBrush As Long Dim OldMode As Long Dim RetVal As Long Dim StepSize As Long Dim X As Long Dim FillArea As RECT OldMode = Me.ScaleMode Me.ScaleMode = 3 StepSize = 1 Me .ScaleHeight / 80 Color = 255 FillArea.left = 0 FillArea.right = Me.ScaleWidth FillArea.top = 0 FillArea.bottom = StepSize For X = 1 To 80 hBrush = CreateSolidBrush (RGB (Color / 2, Color * 2, Color )) RETVAL = FillRect (me.hdc, fill Area, hBrush) RetVal = DeleteObject (hBrush) Color = Color -. 2 If Color <0 Then Color = 0 FillArea.top = FillArea.bottom FillArea.bottom = FillArea.bottom StepSize Next Me.ScaleMode = OldMode End Sub58 disable screen protection Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As LongConst SPI_SETSCREENSAVEACTIVE = 17Const SPIF_SENDWININICHANGE = & H2Const SPIF_UPDATEINIFILE = & H1 Private Sub Form_Load () SystemParametersInfo SPI_STETSCREENSAVEAVE, 0, 0, SPIF_UPDATEENIFILE OR SPIF_SENDWININICHANGEEND SUB59. Similar to the QQ interface button. Command is container with Picturebox. Private Sub Form_Load () me.windowstate = 2with Picture1.width = 1200 60.Height = 4860nd Withdim i as integer I = Command1.count - 1 to 0 step -1with command1 (i) .width = 1200.Height = 300. TOP = Picture1.ScaleHeight - 300 * (Command1.count - i) .left = 0.cAption = "Packet" & i 1nd Withxt iCommand1 (0) .top = 0nd Sub Private Sub Command1_Click (INDEX AS Integer) Picture1.Setfocus' Points Focus to Picture1 is to do not let the button appear black box DIM i as integerifor i = 1 to indexcommand1 (i) .top = 300 * inext ifor i = command1.count - 1 to index 1 step -1command1 (i) .top = Picture1.scaleHeight - 300 * (Command1.count - i) Next Ind Sub 60.alpha blendPrivate Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, _ ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, _ ByVal heightSrc As Long, ByVal dreamAKA As Long) As Long 'only Windows 98 or Latter Dim Num As Byte, nN%, nBlend & Private Sub Run_Blending () Num = 255 nN = 5Do DoEventsnBlend = VBBLUE - Clng (NUM) * (Vbyellow 1) Num = Num - nn if Num = 0 THEN NN = -5 elseif Num = 255 THEN NN = 5 End if Me.Cls Alphablend Me.HDC, 0, 0, PICSRC. ScaleWidth, picSrc.ScaleHeight, picSrc.hDC, 0, 0, picSrc.ScaleWidth, picSrc.ScaleHeight, nBlendLoopEnd SubPrivate Sub Form_Activate () Call Run_BlendingEnd SubPrivate Sub Form_Unload (Cancel As Integer) End 'STOP Do loopEnd Sub 61. Simple Bezier curve drawing Option ExplicitPrivate Type POINTAPI x As Long y As LongEnd TypePrivate Declare Function PolyBezier Lib "gdi32" _ (ByVal hdc As Long, _ lppt As POINTAPI, _ ByVal cpoints As Long) As Long Dim Points (0 to 3) As Pointapidim Oldpoint As Pointapidim Index As INTEGERPRIVATE SUB FORM_LOAD () CAPTION = "Draw the Bezier Curve" Scalemode = 3END SUB Private Sub Form_MouseDown (Button As Integer, X As Single, Y As Single) Points (Index) .x = x: Points (Index). Y = Y IF INDEX = 0 THEN CLS Else Line (Oldpoint.x , OldPoint.y) - (x, y) 'Draw feature polygon end if oldpoint.x = x: Oldpoint.y = y circle (x, y), 3, vbplue if index = 3 Then Form1.ForeColor = VBred Polybezier Me .hdc, Points (0), 4 'Draw Bayser Curve Index = 0 else index = index 1 End IFEND SUB 56. Create a GUID 'GUID is the abbreviation of globally unique Identifier. From a special algorithm to generate these 128-bit numbers, guarantees that there is certainly available, but there is too much number, so the algorithm is particularly The number of repetitions, this situation will not be seen in your life. ActiveX control has a Guid for mutual distinguish. How do you use GUID in your own program? For example, each entry for a database is required At the time of a unique key. The following code will give you an answer: Option ExplicitPrivate Type GUID Data1 As Long Data2 As Long Data3 As Long Data4 (8) As ByteEnd TypePrivate Declare Function CoCreateGuid Lib "ole32.dll" (pguid As GUID) As LongPrivate Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long Private Function GUIDGen () As String Dim uGUID As GUID Dim sGUID As String Dim bGUID () As Byte Dim lLen As Long Dim RetVal As Long lLen = 40 bGUID = String (lLen, 0) CocreateGuid UGUID 'converts the structure into a displayable string RetVal = stringFromGuid2 (UGUID, Varptr (bguid (0)), LLEN SGUID = BGUID IF (ASC (MID $ (SGUID, Retval, 1)) = 0 ) THEN RETVAL = RETVAL - 1 Guidgen = Left $ (sguid, retval) End function private subs cmdguid_click () txtGuid.text = guidgenend sub 57. Create a gradient form Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As LongPrivate Declare Function FillRect lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function DeleteObject lib "gdi32" (ByVal hObject As Long) As Long Private Type RECT left As Long top As Long right As Long bottom As Long End TypePrivate Sub Form_Paint () Dim Color As Long Dim hBrush As Long Dim OldMode As Long Dim RetVal As Long Dim StepSize As Long Dim X As Long Dim FillArea As RECT OldMode = Me.ScaleMode Me.ScaleMode = 3 StepSize = 1 Me .ScaleHeight / 80 Color = 255 FillArea.left = 0 FillArea.right = Me.ScaleWidth FillArea.top = 0 FillArea.bottom = StepSize For X = 1 To 80 hBrush = CreateSolidBrush (RGB (Color / 2, Color * 2, Color )) RETVAL = FillRect (me.hdc, fill Area, hBrush) RetVal = DeleteObject (hBrush) Color = Color -. 2 If Color <0 Then Color = 0 FillArea.top = FillArea.bottom FillArea.bottom = FillArea.bottom StepSize Next Me.ScaleMode = OldMode End Sub58 disable screen protection Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As LongConst SPI_SETSCREENSAVEACTIVE = 17Const SPIF_SENDWININICHANGE = & H2Const SPIF_UPDATEINIFILE = & H1 Private Sub Form_Load () SystemParametersInfo SPI_STETSCREENSAVEAVE, 0, 0, SPIF_UPDATEENIFILE OR SPIF_SENDWININICHANGEEND SUB59. Similar to the QQ interface button. Command is container with Picturebox. Private Sub Form_Load () me.windowstate = 2with Picture1.width = 1200 60.Height = 4860nd Withdim i as integer I = Command1.count - 1 to 0 step -1with command1 (i) .width = 1200.Height = 300. TOP = Picture1.ScaleHeight - 300 * (Command1.count - i) .left = 0.cAption = "Packet" & i 1nd Withxt iCommand1 (0) .top = 0nd Sub Private Sub Command1_Click (INDEX AS Integer) Picture1.Setfocus' Points Focus to Picture1 is to do not let the button appear black box DIM i as integerifor i = 1 to indexcommand1 (i) .top = 300 * inext ifor i = command1.count - 1 to index 1 step -1command1 (i) .top = Picture1.scaleHeight - 300 * (Command1.count - i) Next Ind Sub 60.alpha blendPrivate Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, _ ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, _ ByVal heightSrc As Long, ByVal dreamAKA As Long) As Long 'only Windows 98 or Latter Dim Num As Byte, nN%, nBlend & Private Sub Run_Blending () Num = 255 nN = 5Do DoEventsnBlend = VBBLUE - Clng (NUM) * (Vbyellow 1) Num = Num - nn if Num = 0 THEN NN = -5 elseif Num = 255 THEN NN = 5 End if Me.Cls Alphablend Me.HDC, 0, 0, PICSRC. ScaleWidth, picSrc.ScaleHeight, picSrc.hDC, 0, 0, picSrc.ScaleWidth, picSrc.ScaleHeight, nBlendLoopEnd SubPrivate Sub Form_Activate () Call Run_BlendingEnd SubPrivate Sub Form_Unload (Cancel As Integer) End 'STOP Do loopEnd Sub 61. Simple Bezier curve drawing Option ExplicitPrivate Type POINTAPI x As Long y As LongEnd TypePrivate Declare Function PolyBezier Lib "gdi32" _ (ByVal hdc As Long, _ lppt As POINTAPI, _ ByVal cpoints As Long) As Long Dim Points (0 to 3) As Pointapidim Oldpoint As Pointapidim Index As INTEGERPRIVATE SUB FORM_LOAD () CAPTION = "Draw the Bezier Curve" Scalemode = 3END SUB Private Sub Form_MouseDown (Button As Integer, X As Single, Y As Single) Points (Index) .x = x: Points (Index). Y = Y IF INDEX = 0 THEN CLS Else Line (Oldpoint.x , OldPoint.y) - (x, y) 'Draw feature polygon end if oldpoint.x = x: Oldpoint.y = y circle (x, y), 3, vbplue if index = 3 Then Form1.ForeColor = VBred Polybezier Me .hdc, Points (0), 4 'Draw Bayser Curve Index = 0 else index = index 1 End IFEND SUB 63. Display Browse Folder dialog Option Explicit 'Browse for Folder dialog box' called by :: string = BrowseForFolders (Hwnd, TitleOfDialog) 'For example: String1 = BrowseForFolders (Hwnd, "Select target folder ...") Public Type BrowseInfohwndOwner As LongpIDLRoot As LongpszDisplayName As LonglpszTitle As LongulFlags As LonglpfnCallback As LonglParam As LongiImage As LongEnd TypePublic Const BIF_RETURNONLYFSDIRS = 1Public Const MAX_PATH = 260Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String , ByVal lpString2 As String) As LongPublic Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As LongPublic Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Function BrowseForFolder (hwndOwner As Long, sPrompt AS STRING AS STRING DIM INTEGER DIM LPIDLIST AS Long Dim Lresult As Long Dim Spath AS String Dim Udtbi As BrowseInfo 'Initialization Variables with Udtbi. hwndOwner = hwndOwner .lpszTitle = lstrcat (sPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS End With 'call API lpIDList = SHBrowseForFolder (udtBI) If lpIDList Then sPath = String $ (MAX_PATH, 0) lResult = SHGetPathFromIDList (lpIDList, sPath) Call CoTaskMemFree (LPIDLIST) Inull = INSTR (Spath, VBnullchar) if INULL THEN SPATH = Left $ (Spath, Inull - 1) End if 'If the selection cancels, spath = "" BrowseForfolder = Spathend Function 64. Registration reading and writing module Option Explicit 'Registry reader module' This program needs 3 buttonsPublic Const REG_DWORD = 4Const ERROR_SUCCESS = 0 & Const KEY_ALL_ACCESS = & H3FPublic Const REG_SZ = 1 'Unicode nul terminated stringPublic Const REG_BINARY = 3' Free form binaryPublic Const HKEY_CURRENT_USER = & H80000001Public Const HKEY_LOCAL_MACHINE = & H80000002Public Const Reg1_key = "Software / Microsoft / Windows / CurrentVersion / Run" public constreg2_key = "software / microsoft / windows / currentversion / runservices" Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPublic Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As LongPublic Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As LongPublic Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As LongPublic Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As LongPublic Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As LongPublic Function RegQueryStringValue (ByVal hK ey As Long, ByVal strValueName As String) As String Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long 'retrieve nformation about the key lResult = RegQueryValueEx (hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) If lResult = 0 Then If lValueType = REG_SZ Then 'Create a buffer strBuf = String (lDataBufSize, Chr $ (0))' retrieve the key's content lResult = RegQueryValueEx (hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) If lResult = 0 THEN 'REMOVE The Unnecessary ChR $ (0)' s RegQueryStringValue = Left $ (strBuf, InStr (1, strBuf, Chr $ (0)) - 1) End If ElseIf lValueType = REG_BINARY Then Dim strData As Integer 'retrieve the key's value lResult = RegQueryValueEx (hKey, strValueName, 0, 0 , strData, lDataBufSize) If lResult = 0 Then RegQueryStringValue = strData End If End If End IfEnd FunctionPublic Function GetString (hKey As Long, strPath As String, strValue As String) Dim Ret 'Open the key RegOpenKey hKey, strPath, Ret' Get the key's content GetString = RegQueryStringValue (Ret, strValue) 'Close the key RegCloseKey RetEnd FunctionPublic Sub saveString (hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret' Create a new key RegCreateKey hKey, strPath, Ret ' Save a string to the key regsetvalueex return, strvalue, 0, reg_sz, byval strdata, len (strdata) 'Close the key regclosekey Retend Subp ublic Sub SaveStringLong (hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret' Set the key's value RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte (strData ), 4 'close the key RegCloseKey RetEnd SubPublic Sub DelSetting (hKey As Long, strPath As String, strValue As String) Dim Ret' Create a new key RegCreateKey hKey, strPath, Ret 'Delete the key's value RegDeleteValue Ret, strValue' close the Key Regclosekey Retend Subpublic Sub SaveRegdword (HKEY As Long, String, StrData As String) DIM RET ' Create a New Key RegcreateKey HKEY, STRPATH, RET 'SAVE A DWORD TOTVALUEEX RET, STRVALUENAME, 0, REG_DWORD, CBYTE (STRDATA), 4' Close The Key Regclosekey Retend Sub
