vb编程68例

yulijin608 发表于 2005-1-6 11:36:00

本帖最后由作者于 2005-1-6 12:02:34 编辑 1. 如何消除textbox中按下回车时的beep声？ Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then KeyAscii = 0 End If End Sub

2.Textbox获得焦点时自动选中。 Private Sub Text1_GotFocus() Text1.SelStart = 0 Text1.SelLength = Len(Text1.Text) End Sub

3.屏蔽textbox控件自身的右键菜单，并显示自己的菜单。 方法一： Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y _ As Single) If Button = 2 Then Text1.Enabled = False Text1.Enabled = True PopupMenu mymenu End If End Sub

方法二：回调函数 module： Option Explicit Public OldWindowProc As Long ' 保存默认的窗口函数的地址 Public Const WM_CONTEXTMENU = &H7B ' 当右击文本框时，产生这条消息 Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private 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 Public Function SubClass_WndMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp _ As Long, ByVal lp As Long) As Long ' 如果消息不是WM_CONTEXTMENU，就调用默认的窗口函数处理 If Msg <> WM_CONTEXTMENU Then SubClass_WndMessage = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp) Exit Function End If SubClass_WndMessage = True End Function 窗体中： Private Const GWL_WNDPROC = (-4) Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y _ As Single) If Button = 1 Then Exit Sub OldWindowProc = GetWindowLong(Text1.hWnd, GWL_WNDPROC) ' 取得窗口函数的地址 ' 用SubClass_WndMessage代替窗口函数处理消息 Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, AddressOf SubClass_WndMessage) End Sub Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then Exit Sub ' 恢复窗口的默认函数 Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, OldWindowProc) PopupMenu mymenu End Sub

yulijin608 发表于 2005-1-6 11:36:00

4. 设置TEXTBOX为只读属性 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 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd _ As Long, ByVal nIndex As Long) As Long Private Const GWL_STYLE = (-16) Private Const EM_SETREADONLY = &HCF Private Sub Command1_Click() Dim l As Long If (GetWindowLong(Text1.hwnd, GWL_STYLE) And &H800) Then Text1.Text = "This is a read/write text box." '文本窗口是只读窗口,设置为可读写窗口 l = SendMessage(Text1.hwnd, EM_SETREADONLY, False, vbNull) Text1.BackColor = RGB(255, 255, 255) '将背景设置为白色 Command1.Caption = "Read&Write" Else Text1.Text = "This is a readonly text box." '文本窗口是可读写窗口,设置为只读窗口 l = SendMessage(Text1.hwnd, EM_SETREADONLY, True, vbNull) Text1.BackColor = vbInactiveBorder '将背景设置为灰色 Command1.Caption = "&ReadOnly" End If End Sub

5. 利用API函数MessageBox代替MSGBOX函数可以使得Timer控件正常工作

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 Long Private Sub Command1_Click() MsgBox "时钟变的无效了" End Sub Private Sub Command2_Click() MessageBox Me.hwnd, "时钟正常运行", "hehe", 0 End Sub Private Sub Timer1_Timer() Static i As Integer i = i + 1 Text1.Text = i End 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 Long Public Sub SetOnTop(ByVal IsOnTop As Integer) Dim rtn As Long If IsOnTop = 1 Then rtn = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 3) Else rtn = SetWindowPos(Form1.hwnd, -2, 0, 0, 0, 0, 3) End If End Sub Private Sub Command1_Click() SetOnTop 1 '将窗口置于最上面 End Sub Private Sub Command2_Click() SetOnTop 0 End Sub

7.只容许运行一个程序实例（利用互斥体）

选择启动对象为sub main() module: Public Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _ (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName _ As String) As Long Public Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Public 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) '这一行可千万不能删除啊 Debug.Print Err.LastDllError If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then MsgBox "More than one instance" Else Form1.Show End If End Sub

8.窗体标题栏闪烁 Option Explicit Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert _ As Long) As Long Private Sub tmrFlash_Timer() Static mFlash As Boolean FlashWindow hwnd, Not mFlash End Sub 8. 拷屏

方法一：利用模拟键盘 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 = 1 Const theForm = 0 Private Sub Command1_Click() Call keybd_event(vbKeySnapshot, theForm, 0, 0) '若theForm改成theScreen则Copy整个Screen DoEvents Picture1.Picture = Clipboard.GetData(vbCFBitmap) End Sub

yulijin608 发表于 2005-1-6 11:37:00

9. 为程序注册热键

方法一：修改注册表 Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id _ As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id _ As Long) As Long Private 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 Long Private Declare Function WaitMessage Lib "user32" () As Long Private Type POINTAPI x As Long y As Long End Type Private Type Msg hWnd As Long Message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type ' 声明常数 Private Const MOD_ALT = &H1 Private Const MOD_CONTROL = &H2 Private Const MOD_SHIFT = &H4 Private Const PM_REMOVE = &H1 Private Const WM_HOTKEY = &H312 Private HotKey_Fg As Boolean Private Sub Form_Load() Dim Message As Msg '注册 Ctrl+Y 为热键 RegisterHotKey Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyY 'RegisterHotKey Me.hWnd, &HBFF2&, MOD_CONTROL, vbKeyU Me.Show Form1.Hide '等待处理消息 HotKey_Fg = False Do While Not HotKey_Fg '等待消息 WaitMessage '检查是否热键被按下 If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then Form1.Show 1 End If '转让控制权,允许操作系统处理其他事件 DoEvents Loop End Sub Private Sub Form_Unload(Cancel As Integer) HotKey_Fg = True '撤销热键的注册 Call UnregisterHotKey(Me.hWnd, &HBFFF&) End Sub

方法二：SendMessage 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 Private Const WM_SETHOTKEY = &H32 Private Const HOTKEYF_SHIFT = &H1 Private Const HOTKEYF_ALT = &H4 Private Sub Form_Load() Dim l As Long Dim wHotkey As Long wHotkey = (HOTKEYF_ALT) * (2 ^ 8) + 65 '定义ALT+A为热键 l = SendMessage(Me.hwnd, WM_SETHOTKEY, wHotkey, 0) End Sub

10.在状态栏显示无边框窗体图标。 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long) As Long Const GWL_STYLE = (-16&) Const WS_SYSMENU = &H80000 Private Sub Form_Load() 'Make Form's Icon visible in the taskbar SetWindowLong Me.hWnd, GWL_STYLE, GetWindowLong(Me.hWnd, GWL_STYLE) Or WS_SYSMENU End Sub

11. 记录窗体的大小及位置和程序中的一些设置 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 Sub Private 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 Sub

12. 解决mschart控件数据更改时的闪动现象 1、在有MSChart控件的窗体中另外加入一个PictureBox控件，如MSChart1和Picture1。 2、使Picture1和MSChart1大小一致，位置相同（通过左对齐和顶端对齐）。 3、使Picture1在MSChart1前端，设置Picture1的Visible为False，即不可见。只有刷新数据时Picture1才显示。 '刷新数据过程 Private Sub Refresh() Dim V_newchar() 'n维数组 …… Picture1.Visible = True MSChart1.ChartData = V_newchar '给MSChart1重新赋值,即刷新数据 MSChart1.EditCopy '将当前图表的图片复制到剪贴板中 Picture1.Picture = Clipboard.GetData() '给Picture1赋值剪贴板中的图片 End Sub 这样每一次刷新数据时Picture1显示的图片都不会产生闪烁现象

yulijin608 发表于 2005-1-6 11:38:00

13. 无边框窗体的右键菜单 设计无边框窗体时，如果使用菜单编辑器，就会自动改变成有边框的窗体，此时，可以在另外一个窗体中（一般情况下你的程序应该不止一个窗体的吧，如果真的只有一个，可以利用其他人写的类，添加右键）编辑菜单（VISIBLE属性设为FALSE），然后在本窗体中调用。调用形式如下： Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 2 Then PopupMenu Form2.mymenu End If End Sub

14.创建圆角无边框窗体 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 Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As _ Long, ByVal bRedraw As Boolean) As Long Private Sub Form_Load() hround = CreateRoundRectRgn(0, 0, ScaleX(Form1.ScaleWidth, vbTwips, vbPixels), _ ScaleY(Form1.ScaleHeight, vbTwips, vbPixels), 20, 20) SetWindowRgn Me.hwnd, hround, True DeleteObject hround End Sub

15.拖动没有标题栏的窗体 方法一： Private Declare Function ReleaseCapture Lib "user32" () As Long 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 Private Const HTCAPTION = 2 Private Const WM_NCLBUTTONDOWN = &HA1 Private 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 If End Sub 方法二：回调函数 module: Public Const GWL_WNDPROC = (-4) Public Const WM_NCHITTEST = &H84 Public Const HTCLIENT = 1 Public Const HTCAPTION = 2 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 Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As _ Long, ByVal nIndex As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As _ Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public prevWndProc As Long Function 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 If End Function 窗体中: Private Sub Form_Load() prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC) SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc End Sub Private Sub Form_Unload(Cancel As Integer) SetWindowLong Me.hWnd, GWL_WNDPROC, prevWndProc End Sub 16. 半透明窗体 Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _ ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Private Const GWL_EXSTYLE = (-20) Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal _ hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal _ hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Sub Form_Load() Dim rtn As Long rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '取的窗口原先的样式 rtn = rtn Or WS_EX_LAYERED ' 使窗体添加上新的样式WS_EX_LAYERED SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn ' 把新的样式赋给窗体 SetLayeredWindowAttributes Me.hwnd, 0, 200, LWA_ALPHA End Sub

yulijin608 发表于 2005-1-6 11:38:00

17.开机启动（函数及常数声明略） Private Sub Form_Load() Dim hKey As Long, SubKey As String, Exe As String SubKey = "Software\Microsoft\Windows\CurrentVersion\Run" Exe = "可执行文件的路径" RegCreateKey HKEY_CURRENT_USER, SubKey, hKey RegSetvalueEx hKey, "autorun", 0, REG_SZ, ByVal Exe,LenB(StrConv(Exe, vbFromUnicode)) + 1 RegCloseKey hKey End Sub

18.关闭显示器 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 Const WM_SYSCOMMAND = &H112& Const SC_MONITORPOWER = &HF170& Private Sub Command1_Click() SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 2& '关闭显示器 End Sub Private Sub Command2_Click() SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1& '打开显示器 End Sub

19. 在程序结束时自动关闭由SHELL打开的程序。 Private Const PROCESS_QUERY_INFORMATION = &H400 '关闭由SHELL函数打开的文件 Private Const PROCESS_TERMINATE = &H1 Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _ ByVal uExitCode As Long) As Long Dim ProcessId As Long Private Sub Command1_Click() ProcessId = Shell("notepad.exe.", vbNormalFocus) End Sub Private 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. 关闭、重启计算机 Public Declare Function ExitWindowsEx Lib "user32" Alias "ExitWindowsEx" (ByVal _ uFlags As Long, ByVal dwReserved As Long) As Long ExitWindowsEx 1，0 关机 ExitWindowsEx 0，1 重新启动

yulijin608 发表于 2005-1-6 11:39:00

21.显示关机提示框 Private Declare Function SHRestartSystemMB Lib "shell32" Alias "#59" (ByVal hOwner _ As Long, ByVal sExtraPrompt As String,

ByVal uFlags As Long) As Long Const EWX_LOGOFF = 0 Const EWX_SHUTDOWN = 1 Const EWX_REBOOT = 2 Const EWX_FORCE = 4 Const EWX_POWEROFF = 8 Private Sub Command1_Click() SHRestartSystemMB Me.hWnd, PROMPT, EWX_LOGOFF End Sub

22.右键托盘图标后必须电击他才可以消失，怎么办？ Case WM_RBUTTONUP '鼠标在图标上右击时弹出菜单 SetForegroundWindow Me.hwnd Me.PopupMenu mnuTray 加一句 SetForegroundWindow Me.hwnd

23. 将progressbar嵌入statusbar中 Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal _ hWndNewParent As Long) As Long Private Sub Command1_Click() With ProgressBar1 .Max = 1000 Dim i As Integer For i = 1 To 1000 .Value = i Next i End With End Sub Private 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 - 150 End Sub '相对位置你可以自己再调一下

24.使你的程序界面具有XP风格 产生一个和你的可执行程序同名的后缀为exe.manifest的文件，并和可执行文件放在同一路径中。 代码中加入: Private Declare Sub InitCommonControls Lib "comctl32.dll" () Private Sub Form_Initialize() InitCommonControls 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编辑。 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="CompanyName.ProductName.YourApp" type="win32" /> <description>Your application description here.</description> <dependency> <dependentAssembly> <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*" /> </dependentAssembly> </dependency> </assembly>

yulijin608 发表于 2005-1-6 11:40:00

25.如何打印PictureBox中的所有控件

添加另外一个PictureBox，然后： Private Const WM_PAINT = &HF Private Const WM_PRINT = &H317 Private Const PRF_CLIENT = &H4& Private Const PRF_CHILDREN = &H10& Private Const PRF_OWNED = &H20& Private Const PHYSICALOFFSETX As Long = 112 Private Const PHYSICALOFFSETY As Long = 113 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _ As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nindex _ As Long) As Long private Sub Form_Load() Picture1.AutoRedraw = True Picture2.AutoRedraw = True Picture2.BorderStyle = 0 Picture2.Visible = False End Sub Private 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, PHYSICALOFFSETY) 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 + PRF_CLIENT + PRF_OWNED) DoEvents Printer.Print "" .PaintPicture Picture2.Image, x - xmargin, y - ymargin .EndDoc End With End Sub

26.冒泡排序如下： Sub BubbleSort(List() As Double) Dim First As Double, Last As Double Dim i As Integer, j As Integer Dim Temp As Double First = LBound(List) Last = UBound(List) For i = First To Last - 1 For j = i + 1 To Last If List(i) > List(j) Then Temp = List(j) List(j) = List(i) List(i) = Temp End If Next j Next i End Sub 27.清空回收站

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias _ "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, _ ByVal dwFlags As Long) As Long Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long Private Const SHERB_NOCONFIRMATION = &H1 Private Const SHERB_NOPROGRESSUI = &H2 Private Const SHERB_NOSOUND = &H4 Private Sub Command1_Click() Dim retval As Long ' return value retval = SHEmptyRecycleBin(RecycleBin.hwnd, "", SHERB_NOPROGRESSUI) ' 清空回收站, 确认 ' 若有错误出现，则返回回收站图示 If retval <> 0 Then ' error retval = SHUpdateRecycleBinIcon() End If End Sub Private Sub Command2_Click() Dim retval As Long ' return value ' 清空回收站, 不确认 retval = SHEmptyRecycleBin(RecycleBin.hwnd, "", SHERB_NOCONFIRMATION) ' 若有错误出现，则返回回收站图示 If retval <> 0 Then ' error retval = SHUpdateRecycleBinIcon() End If Command1_Click End Sub

 28.获得系统文件夹的路径 Private Declare Function GetSystemDirectory Lib "kernel32" Alias _ "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private 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 : "; syspath End Sub

yulijin608 发表于 2005-1-6 11:40:00

29.动态增加控件并响应事件 Option Explicit '通过使用WithEvents关键字声明一个对象变量为新的命令按钮 Private WithEvents NewButton As CommandButton '增加控件 Private Sub Command1_Click() If NewButton Is Nothing Then '增加新的按钮cmdNew Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me) '确定新增按钮cmdNew的位置 NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top NewButton.Caption = "新增的按钮" NewButton.Visible = True End If End Sub '删除控件(注：只能删除动态增加的控件) Private Sub Command2_Click() If NewButton Is Nothing Then Else Controls.Remove NewButton Set NewButton = Nothing End If End Sub '新增控件的单击事件 Private Sub NewButton_Click() MsgBox "您选中的是动态增加的按钮！" End Sub 30.得到磁盘序列号 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 = SerialNum End Function 调用形式 Label1.Caption = GetSerialNumber("c:\")

31.打开屏幕保护 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 '我们将要调用的那个消息，在MSDN中搜索WM_SYSCOMMAND就可以找到具体说明 Const WM_SYSCOMMAND = &H112 '这个参数指明了我们让系统启动屏幕保护 Const SC_SCREENSAVE = &HF140& Private Sub Command1_Click() SendMessage Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0 End Sub

 32.获得本机IP地址 方法一：利用Winsock控件 winsockip.localip 方法二： 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 MIB_IPADDRTABLE On Error GoTo END1 GetIpAddrTable 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 地址。" & vbCrLf strIP = strIP & "------------------------------------------------" & vbCrLf & vbCrLf For Tel = 0 To Listing.dEntrys - 1 CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))), Len _(Listing.mIPInfo(Tel)) strIP = strIP & "IP 地址 : " & ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr) & vbCrLf Next Exit Sub END1: MsgBox "ERROR" End Sub Private Sub Form_Load() Start MsgBox strIP End Sub

yulijin608 发表于 2005-1-6 11:41:00

33. 用键盘方向键控制COMBOX 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 Const CB_SHOWDROPDOWN = &H14F Dim bDrop As Boolean Private isDo As Boolean Private Sub Combo1_Click() If Not isDo Then isDo = True '<----------回置状态 Exit Sub Else: MsgBox "safd" End If End Sub Private Sub Combo1_DropDown() bDrop = True End Sub Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 40 Then isDo = False SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, 1, 0 ElseIf 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 End If End Sub Private Sub Combo1_KeyUp(KeyCode As Integer, Shift As Integer) If Combo1.Text = Combo1.List(0) Then isDo = True End If End Sub Private Sub Form_Load() isDo = True Combo1.AddItem "abcd" Combo1.AddItem "abcd1" Combo1.AddItem "abcd2" Combo1.AddItem "abcd3" End Sub 35.VB下的CRC校验程序 一计算法 计算法就是依据CRC校验码的产生原理来设计程序。其优点是模块代码少，修改灵活，可移植性好。其缺点为计算量大。为了便于理解，这里假

定了三位数据，而多项式码为A001(hex)。 　　在窗体上放置一命令按钮Command1，并添加如下代码：

　　Private Sub Command1_Click() 　　　Dim CRC() As Byte 　　　Dim d() As Byte '待传输数据 　　　ReDim d(2) As Byte 　　　d(0) = 123 　　　d(1) = 112 　　　d(2) = 135 　　　CRC = CRC16(d) '调用CRC16计算函数 　　　'CRC(0)为高位 　　　'CRC(1)为低位 　　End Sub 　　注意：在数据传输时CRC的低位可能在前，而高位在后。

　　Function CRC16(data() As Byte) As String 　　　Dim CRC16Lo As Byte, CRC16Hi As Byte　　　'CRC寄存器 　　　Dim CL As Byte, CH As Byte　　　　　　　　'多项式码&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) '每一个数据与CRC寄存器进行异或 　　　　For Flag = 0 To 7 　　　　　SaveHi = CRC16Hi 　　　　　SaveLo = CRC16Lo 　　　　　CRC16Hi = CRC16Hi \ 2　　　　　　'高位右移一位 　　　　　CRC16Lo = CRC16Lo \ 2　　　　　　'低位右移一位 　　　　　If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1 　　　　　　CRC16Lo = CRC16Lo Or &H80　　　'则低位字节右移后前面补1 　　　　　End If　　　　　　　　　　　　　 '否则自动补0 　　　　　If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或 　　　　　　CRC16Hi = CRC16Hi Xor CH 　　　　　　CRC16Lo = CRC16Lo Xor CL 　　　　　End If 　　　　Next Flag 　　　Next i 　　　Dim ReturnData(1) As Byte 　　　ReturnData(0) = CRC16Hi　　　　　　　'CRC高位 　　　ReturnData(1) = CRC16Lo　　　　　　　'CRC低位 　　　CRC16 = ReturnData 　　End Function

2．查表法 　　查表法的优缺点与计算法的正好相反。为了便于比较，这里所有的假定与计算法的完全相同，都而在窗体上放置一个Command1的按钮，其

代码部分与上面的也完全一致。下面只介绍CRC函数的编写源代码。

　　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)　　　　'低位处理 　　　　CRC16Hi = GetCRCHi(iIndex)　　　　　　　　　　'高位处理 　　　Next i 　　　Dim ReturnData(1) As Byte 　　　ReturnData(0) = CRC16Hi　　　　'CRC高位 　　　ReturnData(1) = CRC16Lo　　　　'CRC低位 　　　CRC16 = ReturnData 　　End Function

　　'CRC低位字节值表 　　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, &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, &H41, &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, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &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, &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, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &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, &HC0, &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, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40) 　　End Function

　　'CRC高位字节值表 　　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, &HE, &HA, &HCA, &HCB, &HB, &HC9, &H9, &H8, &HC8, &HD8, &H18, &H19, &HD9, &H1B, &HDB,

&HDA, &H1A, &H1E, &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, &H3E, &HFE, &HFA, &H3A, &H3B, &HFB, &H39, &HF9, &HF8, &H38, &H28, &HE8, &HE9, &H29, &HEB,

&H2B, &H2A, &HEA, &HEE, &H2E, &H2F, &HEF, &H2D, &HED, &HEC, &H2C, &HE4, &H24, &H25, &HE5, &H27, &HE7, &HE6, &H26, &H22, &HE2,

&HE3, &H23, &HE1, &H21, &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, &H6B, &HAB, &H69, &HA9, &HA8, &H68, &H78, &HB8, &HB9, &H79, &HBB, &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.如何打开光驱 Public Declare Function CDdoor Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString

As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Call CDdoor("set CDAudio door open", 0, 0, 0) '打开光驱 Call CDdoor("set CDAudio door closed", 0, 0, 0) '关闭光驱

yulijin608 发表于 2005-1-6 11:43:00

37.检测是否以联网及联网方式 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 窗体中 Private Sub Form_Load() ' Determine whether 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 If End Sub

38.得到当前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 usage End Type Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Public Const SM_CLEANBOOT = 67 Public Const SM_DEBUG = 22 Public Const SM_SLOWMACHINE = 73 Public Const VER_PLATFORM_WIN32s = 0 Public Const VER_PLATFORM_WIN32_WINDOWS = 1 Public Const VER_PLATFORM_WIN32_NT = 2 窗体中

Private Sub Form_Load() Dim myVer As OSVERSIONINFO Dim nl As String Dim q As Long nl = Chr(10) & Chr(13) myVer.dwOSVersionInfoSize = 148 q& = GetVersionEx(myVer) lblWininfo = "" lblMoreWininfo = "" If myVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then lblWininfo = lblWininfo & "运行平台 = Windows 95/98" & nl If myVer.dwPlatformId = VER_PLATFORM_WIN32_NT Then lblWininfo = lblWininfo & "Platform = Windows NT" & nl lblWininfo = lblWininfo & "Version = " & myVer.dwMajorVersion & "." & myVer.dwMinorVersion & " 创建于 " & (myVer.dwBuildNumber And &HFFFF&) & nl lblMoreWininfo = "Windows 现在运行在" If GetSystemMetrics(SM_CLEANBOOT) = 0 Then lblMoreWininfo = lblMoreWininfo & "正常模式" & nl If GetSystemMetrics(SM_CLEANBOOT) = 1 Then lblMoreWininfo = lblMoreWininfo & "安全模式" & nl If GetSystemMetrics(SM_CLEANBOOT) = 2 Then lblMoreWininfo = lblMoreWininfo & "局域网安全模式" & nl If GetSystemMetrics(SM_DEBUG) = True Then lblMoreWininfo = lblMoreWininfo & "Windows Debugging Mode in operation" & nl If GetSystemMetrics(SM_SLOWMACHINE) = True Then lblMoreWininfo = lblMoreWininfo & "这台PC配置太低无法高效运行 Windows." & nl End Sub

39.模拟键盘 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 = &H5B Private Const KEYEVENTF_KEYUP = &H2 Private Const VK_APPS = &H5D Private Const VK_PLAY = &HFA Private Sub DoAction(Index As Integer) Dim VK_ACTION As Long Select Case Index Case 0: '打开资源管理器 VK_ACTION = &H45 Case 1: '查找文件 VK_ACTION = &H46 Case 2: '最小化所有窗口 VK_ACTION = &H4D Case 3: '运行程序 VK_ACTION = &H52 Case 4: '弹出Win菜单 VK_ACTION = &H5B Case 5: '将计算机转如睡眠状态 VK_ACTION = &H5E Case 6: '执行Windows帮助 VK_ACTION = &H70 End Select Call keybd_event(VK_LWIN, 0, 0, 0) Call keybd_event(VK_ACTION, 0, 0, 0) Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0) End Sub

40 延迟函数

Public Sub Delay(DelayTime As Single) Dim BeginTime As Single BeginTime = Timer While Timer < BeginTime + DelayTime DoEvents Wend End Sub 调用形式 delay 1.5 或者用Sleep函数

页: [1] 2 3 4 5 6 7 8

明经CAD社区's Archiver

vb编程68例