VB入门技巧多例4.doc

10.在状态栏显示无边框窗体图标。 1 Private Declare Function SetWindowLong Lib user32 Alias SetWindowLongA (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 2 Private Declare Function GetWindowLong Lib user32 Alias GetWindowLongA (ByVal hWnd _ As Long, ByVal nIndex As Long) As Long 3 Const GWL_STYLE = (-16&) 4 Const WS_SYSMENU = &H80000 5 Private Sub Form_Load() 6 Make Forms Icon visible in the taskbar 7 SetWindowLong Me.hWnd, GWL_STYLE, GetWindowLong(Me.hWnd, GWL_STYLE) Or WS_SYSMENU 8 End Sub11. 记录窗体的大小及位置和程序中的一些设置1 Private Sub Form_Load() 2 Me.Width = GetSetting(App.Title, Me.Name, Width, 7200) 3 Me.Height = GetSetting(App.Title, Me.Name, Height, 6300) 4 Me.Top = GetSetting(App.Title, Me.Name, Top, 100) 5 Me.Left = GetSetting(App.Title, Me.Name, Left, 100) 6 Check1.Value = GetSetting(App.Title, Me.Name, check1, 0) 7 End Sub 8 Private Sub Form_Unload(Cancel As Integer) 9 Call SaveSetting(App.Title, Me.Name, Width, Me.Width) 10 Call SaveSetting(App.Title, Me.Name, Height, Me.Height) 11 Call SaveSetting(App.Title, Me.Name, Top, Me.Top) 12 Call SaveSetting(App.Title, Me.Name, Left, Me.Left) 13 Call SaveSetting(App.Title, Me.Name, check1, Check1.Value) 14 End Sub13. 无边框窗体的右键菜单 设计无边框窗体时，如果使用菜单编辑器，就会自动改变成有边框的窗体，此时，可以在另外一个窗体中（一般情况下你的程序应该不止一个窗体的吧，如果真的只有一个，可以利用其他人写的类，添加右键）编辑菜单（VISIBLE属性设为FALSE），然后在本窗体中调用。调用形式如下： 1 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 2 If Button = 2 Then 3 PopupMenu Form2.mymenu 4 End If 5 End Sub14.创建圆角无边框窗体1 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 Long 2 Private Declare Function DeleteObject Lib gdi32 (ByVal hObject As Long) As Long 3 Private Declare Function SetWindowRgn Lib user32 (ByVal hwnd As Long, ByVal hrgn As _ Long, ByVal bRedraw As Boolean) As Long 4 Private Sub Form_Load() 5 hround = CreateRoundRectRgn(0, 0, ScaleX(Form1.ScaleWidth, vbTwips, vbPixels), _ ScaleY(Form1.ScaleHeight, vbTwips, vbPixels), 20, 20) 6 SetWindowRgn Me.hwnd, hround, True 7 DeleteObject hround 8 End Sub15.拖动没有标题栏的窗体 方法一： 1 Private Declare Function ReleaseCapture Lib user32 () As Long 2 Private Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 3 Private Const HTCAPTION = 2 4 Private Const WM_NCLBUTTONDOWN = &HA1 5 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 6 Dim ncl As Long 7 Dim rel As Long 8 If Button = 1 Then 9 i = ReleaseCapture() 10 ncl = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0) 11 End If 12 End Sub方法二：回调函数 1 module: 2 Public Const GWL_WNDPROC = (-4) 3 Public Const WM_NCHITTEST = &H84 4 Public Const HTCLIENT = 1 5 Public Const HTCAPTION = 2 6 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 Long 7 Declare Function GetWindowLong Lib user32 Alias GetWindowLongA (ByVal hWnd As _ 8 Long, ByVal nIndex As Long) As Long 9 Declare Function SetWindowLong Lib user32 Alias SetWindowLongA (ByVal hWnd As _ 10 Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 11 Public prevWndProc As Long 12 Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal _Param As Long) As Long 13 WndProc = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam) 14 If Msg = WM_NCHITTEST And WndProc = HTCLIENT Then 15 WndProc = HTCAPTION 16 End If 17 End Function 18 窗体中: 19 Private Sub Form_Load() 20 prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC) 21 SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc 22 End Sub 23 Private Sub Form_Unload(Cancel As Integer) 24 SetWindowLong Me.hWnd, GWL_WNDPROC, prevWndProc 25 End Sub16. 半透明窗体1 Private Declare Function SetLayeredWindowAttributes Lib user32 (ByVal hwnd As Long, _ ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long 2 Private Const WS_EX_LAYERED = &H80000 3 Private Const LWA_ALPHA = &H2 4 Private Const GWL_EXSTYLE = (-20) 5 Private Declare Function GetWindowLong Lib user32 Alias GetWindowLongA (ByVal _ 6 hwnd As Long, ByVal nIndex As Long) As Long 7 Private Declare Function SetWindowLong Lib user32 Alias SetWindowLongA (ByVal _ 8 hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 9 Private Sub Form_Load() 10 Dim rtn As Long 11 rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE) 取的窗口原先的样式 12 rtn = rtn Or WS_EX_LAYERED 使窗体添加上新的样式WS_EX_LAYERED 13 SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn 把新的样式赋给窗体 14 SetLayeredWindowAttributes Me.hwnd, 0, 200, LWA_ALPHA 15 End Sub17.开机启动（函数及常数声明略） 1 Private Sub Form_Load() 2 Dim hKey As Long, SubKey As String, Exe As String 3 SubKey = SoftwareMicrosoftWindowsCurrentVersionRun 4 Exe = 可执行文件的路径 5 RegCreateKey HKEY_CURRENT_USER, SubKey, hKey 6 RegSetvalueEx hKey, autorun, 0, REG_SZ, ByVal Exe,LenB(StrConv(Exe, vbFromUnicode) + 1 7 RegCloseKey hKey 8 End Sub18.关闭显示器1 Private Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd _ 2 As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 3 Const WM_SYSCOMMAND = &H112& 4 Const SC_MONITORPOWER = &HF170& 5 Private Sub Command1_Click() 6 SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 2& 关闭显示器 7 End Sub 8 Private Sub Command2_Click() 9 SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1& 打开显示器 10 End Sub19. 在程序结束时自动关闭由SHELL打开的程序。 1 Private Const PROCESS_QUERY_INFORMATION = &H400 关闭由SHELL函数打开的文件 2 Private Const PROCESS_TERMINATE = &H1 3 Private Declare Function OpenProcess Lib kernel32 (ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long 4 Private Declare Function TerminateProcess Lib kernel32 (ByVal hProcess As Long, _ 5 ByVal uExitCode As Long) As Long 6 Dim ProcessId As Long 7 Private Sub Command1_Click() 8 ProcessId = Shell(notepad.exe., vbNormalFocus) 9 End Sub 10 Private Sub Form_Unload(Cancel As Integer) 11 Dim hProcess As Long 12 hProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION, False, _ ProcessId) 13 Call TerminateProcess(hProcess, 3838) 14 End Sub20. 关闭、重启计算机 1 Public Declare Function ExitWindowsEx Lib user32 Alias ExitWindowsEx (ByVal _ 2 uFlags As Long, ByVal dwReserved As Long) As Long 3 ExitWindowsEx 1，0 关机 4 ExitWindowsEx 0，1 重新启动21.显示关机提示框1 Private Declare Function SHRestartSystemMB Lib shell32 Alias #59 (ByVal hOwner _ 2 As Long, ByVal sExtraPrompt As String, 34 ByVal uFlags As Long) As Long 5 Const EWX_LOGOFF = 0 6 Const EWX_SHUTDOWN = 1 7 Const EWX_REBOOT = 2 8 Const EWX_FORCE = 4 9 Const EWX_POWEROFF = 8 10 Private Sub Command1_Click() 11 SHRestartSystemMB Me.hWnd, PROMPT, EWX_LOGOFF 12 End Sub22. 右键托盘图标后必须电击他才可以消失，怎么办？ Case WM_RBUTTONUP 鼠标在图标上右击时弹出菜单 SetForegroundWindow Me.hwnd Me.PopupMenu mnuTray 加一句 SetForegroundWindow Me.hwnd 23. 将progressbar嵌入statusbar中1 Private Declare Function SetParent Lib user32 (ByVal hWndChild As Long, ByVal _ hWndNewParent As Long) As Long 2 Private Sub Command1_Click() 3 With ProgressBar1 4 .Max = 1000 5 Dim i As Integer 6 For i = 1 To 1000 7 .Value = i 8 Next i 9 End With 10 End Sub 11 Private Sub Form_Load() 12 ProgressBar1.Appearance = ccFlat 13 SetParent ProgressBar1.hWnd, StatusBar1.hWnd 14 ProgressBar1.Left = StatusBar1.Panels(1).Left 15 ProgressBar1.Top = 100 16 ProgressBar1.Width = StatusBar1.Panels(1).Width - 50 17 ProgressBar1.Height = StatusBar1.Height - 150 18 End Sub 相对位置你可以自己再调一下24.使你的程序界面具有XP风格 产生一个和你的可执行程序同名的后缀为exe.manifest的文件，并和可执行文件放在同一路径中。 代码中加入: 1 Private Declare Sub InitCommonControls Lib comctl32.dll () 2 Private Sub Form_Initialize() 3 InitCommonControls 4 End Sub注意： 1 工具栏控件一定要用Microsoft Windows Common Controls 5.0，而不要用Microsoft Windows Common Controls 6.0。因为此 InitCommonControls API函数是位于comctl32.dll（Microsoft Windows Common Controls 5.0控件的动态链接库中）。 2 放在FRAME控件中的单远按钮有些“麻烦”！为了解决此问题，可以将单选按钮放在PICTURE控件中（以PICTURE控件作为容器），再将 PICTURE控件放在FRAME控件中，就可以了。 3 必须编译之后才能看到效果 exe.manifest文件中的内容，可用notepad编辑。 1 2 3 9 Your application description here. 10 11 12 20 21 22 25.如何打印PictureBox中的所有控件 添加另外一个PictureBox，然后： 1 Private Const WM_PAINT = &HF 2 Private Const WM_PRINT = &H317 3 Private Const PRF_CLIENT = &H4& 4 Private Const PRF_CHILDREN = &H10& 5 Private Const PRF_OWNED = &H20& 6 Private Const PHYSICALOFFSETX As Long = 112 7 Private Const PHYSICALOFFSETY As Long = 113 8 Private Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd _ 9 As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 10 Private Declare Function GetDeviceCaps Lib gdi32 (ByVal hdc As Long, ByVal nindex _ 11 As Long) As Long 12 private Sub Form_Load() 13 Picture1.AutoRedraw = True 14 Picture2.AutoRedraw = True 15 Picture2.BorderStyle = 0 16 Picture2.Visible = False 17 End Sub 18 Private Sub Command2_Click() 19 Dim retval As Long, xmargin As Single, ymargin As Single 20 Dim x As Single, y As Single 21 x = 1: y = 1 22 With Printer 23 .ScaleMode = vbInches 24 xmargin = GetDeviceCaps(.hdc, PHYSICALOFFSETX) 25 xmargin = (xmargin * .TwipsPerPixelX) / 1440 26 ymargin = GetDeviceCaps(.hdc, PHYSICALOFFSETY) 27 ymargin = (ymargin * .TwipsPerPixelY) / 1440 28 Picture2.Width = Picture1.Width 29 Picture2.Height = Picture1.Height 30 DoEvents 31 Picture1.SetFocus 32 retval = SendMessage(Picture1.hwnd, WM_PAINT, Picture2.hdc, 0) 33 retval = SendMessage(Picture1.hwnd, WM_PRINT, Picture2.hdc, _ 34 PRF_CHILDREN + PRF_CLIENT + PRF_OWNED) 35 DoEvents 36 Printer.Print 37 .PaintPicture Picture2.Image, x - xmargin, y - ymargin 38 .EndDoc 39 End With 40 End Sub26.冒泡排序 1 Sub BubbleSort(List() As Double) 2 Dim First As Double, Last As Double 3 Dim i As Integer, j As Integer 4 Dim Temp As Double 5 First = LBound(List) 6 Last = UBound(List) 7 For i = First To Last - 1 8 For j = i + 1 To Last 9 If List(i) List(j) Then 10 Temp = List(j) 11 List(j) = List(i) 12 List(i) = Temp 13 End If 14 Next j 15 Next i 16 End Sub27.清空回收站 1 Private Declare Function SHEmptyRecycleBin Lib shell32.dll Alias _ 2 SHEmptyRecycleBinA (ByVal hwnd As Long, ByVal pszRootPath As String, _ 3 ByVal dwFlags As Long) As Long 4 Private Declare Function SHUpdateRecycleBinIcon Lib shell32.dll () As Long 5 Private Const SHERB_NOCONFIRMATION = &H1 6 Private Const SHERB_NOPROGRESSUI = &H2 7 Private Const SHERB_NOSOUND = &H4 8 Private Sub Command1_Click() 9 Dim retval As Long return value 10 retval = SHEmptyRecycleBin(RecycleBin.hwnd, , SHERB_NOPROGRESSUI) 清空回收站, 确认 11 若有错误出现，则返回回收站图示 12 If retval 0 Then error 13 retval = SHUpdateRecycleBinIcon() 14 End If 15 End Sub 16 Private Sub Command2_Click() 17 Dim retval As Long return value 18 清空回收站, 不确认 19 retval = SHEmptyRecycleBin(RecycleBin.hwnd, , SHERB_NOCONFIRMATION) 20 若有错误出现，则返回回收站图示 21 If retval 0 Then error 22 retval = SHUpdateRecycleBinIcon() 23 End If 24 Command1_Click 25 End Sub28.获得系统文件夹的路径 1 Private Declare Function GetSystemDirectory Lib kernel32 Alias _ 2 GetSystemDirectoryA (ByVal lpBuffer As String, ByVal nSize As Long) As Long 3 Private Sub Command1_Click() 4 Dim syspath As String 5 Dim len5 As Long 6 syspath = String(255, 0) 7 len5 = GetSystemDirectory(syspath, 256) 8 syspath = Left(syspath, InStr(1, syspath, Chr(0) - 1) 9 Debug.Print System Path : ; syspath 10 End Sub29.动态增加控件并响应事件1 Option Explicit 2 通过使用WithEvents关键字声明一个对象变量为新的命令按钮 3 Private WithEvents NewButton As CommandButton4 增加控件 5 Private Sub Command1_Click() 6 If NewButton Is Nothing Then 7 增加新的按钮cmdNew 8 Set NewButton = Controls.Add(VB.CommandButton, cmdNew, Me) 9 确定新增按钮cmdNew的位置 10 NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top 11 NewButton.Caption = 新增的按钮 12 NewButton.Visible = True 13 End If 14 End Sub 15 删除控件(注：只能删除动态增加的控件) 16 Private Sub Command2_Click() 17 If NewButton Is Nothing Then 18 Else 19 Controls.Remove NewButton 20 Set NewButton = Nothing 21 End If 22 End Sub 23 新增控件的单击事件 24 Private Sub NewButton_Click() 25 MsgBox 您选中的是动态增加的按钮！ 26 End Sub30.得到磁盘序列号1 Function GetSerialNumber(strDrive As String) As Long 2 Dim SerialNum As Long 3 Dim Res As Long 4 Dim Temp1 As String 5 Dim Temp2 As String 6 Temp1 = String$(255, Chr$(0) 7 Temp2 = String$(255, Chr$(0) 8 Res = GetVolumeInformation(strDrive, Temp1, Len(Temp1), SerialNum, 0, 0, Temp2, _ 9 Len(Temp2) 10 GetSerialNumber = SerialNum 11 End Function 12 调用形式 Label1.Caption = GetSerialNumber(c:)31.打开屏幕保护1 Private Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd _ 2 As Long, ByVal wMsg As Long, ByVal wParam 34 As Long, lParam As Any) As Long 5 我们将要调用的那个消息，在MSDN中搜索WM_SYSCOMMAND就可以找到具体说明 6 Const WM_SYSCOMMAND = &H112 7 这个参数指明了我们让系统启动屏幕保护 8 Const SC_SCREENSAVE = &HF140& 9 Private Sub Command1_Click() 10 SendMessage Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0 11 End Sub32.获得本机IP地址 方法一：利用Winsock控件 winsockip.localip 方法二： 1 Private Const MAX_IP = 255 2 Private Type IPINFO 3 dwAddr As Long 4 dwIndex As Long 5 dwMask As Long 6 dwBCastAddr As Long 7 dwReasmSize As Long 8 unused1 As Integer 9 unused2 As Integer 10 End Type 11 Private Type MIB_IPADDRTABLE 12 dEntrys As Long 13 mIPInfo(MAX_IP) As IPINFO 14 End Type 15 Private Type IP_Array 16 mBuffer As MIB_IPADDRTABLE 17 BufferLen As Long 18 End Type 19 Private Declare Sub CopyMemory Lib kernel32 Alias RtlMoveMemory (Destination _ 20 As Any, Source As Any, ByVal Length As 2122 Long) 23 Private Declare Function GetIpAddrTable Lib IPHlpApi (pIPAdrTable As Byte, _ 24 pdwSize As Long, ByVal Sort As Long) As Long 25 Dim strIP As String 26 Private Function ConvertAddressToString(longAddr As Long) As String 27 Dim myByte(3) As Byte 28 Dim Cnt As Long 29 CopyMemory myByte(0), longAddr, 4 30 For Cnt = 0 To 3 31 ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt) + . 32 Next Cnt 33 ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1) 34 End Function 35 36 Public Sub Start() 37 Dim Ret As Long, Tel As Long 38 Dim bBytes() As Byte 39 Dim Listing As MIB_IPADDRTABLE 40 On Error GoTo END1 41 GetIpAddrTable ByVal 0&, Ret, True 42 If Ret = 0 Then Exit Sub 43 ReDim bBytes(0 To Ret - 1) As Byte 44 GetIpAddrTable bBytes(0), Ret, False 4546 CopyMemory Listi