刘福兴的个人资料

操作任务栏的源代码

查看硬盘空间 '添加Drive1 Label1 Label2Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As LongPrivate Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As LongConst DRIVE_CDROM = 5Public drivenm As String, cddrive As StringPrivate Sub Form_Load() '查找CD-ROM的驱动器号 cddrive = "" For i = 65 To 90 If GetDriveType(Chr$(i) & ":\") = DRIVE_CDROM Then cddrive = UCase(Chr$(i)) & ":\" Exit For End If Next i drivenm = "c:" label1.AutoSize = True Label2.AutoSize = True Drive1.Left = (Me.Width - Drive1.Width) \ 2 Drive1.Drive = "c" Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 gethdEnd SubPrivate Sub Form_Activate() MsgBox "你的光驱在:" & cddriveEnd SubPrivate Sub Drive1_Change() drivenm = Drive1.Drive gethdEnd SubPrivate Sub gethd() '得知硬盘容量 On Error Resume Next Dim dfs&, cl1&, cl2&, sec1&, byt1&, tspace&, getdiskvolm&, lSize&, kk% Dim hdtype$, hdspace$, hdfspace$ dfs = GetDiskFreeSpace(drivenm, sec1, byt1, cl1, cl2) If dfs Then cl2 = Int(cl2 * sec1 / 1024 * byt1) lSize = Len(Format$(cl2, "#########")) If lSize < 11 Then kk = 11 - lSize End If hdspace = Space(kk) + Format$(cl2, "#########") + " KBytes" cl1 = Int(cl1 * sec1 / 1024 * byt1) lSize = Len(Format$(cl1, "#########")) If lSize < 11 Then kk = 11 - lSize End If hdfspace = Space(kk) + Format$(cl1, "#########") + " KBytes" Else hdspace = "" hdfspace = "" End If label1.Caption = "你的" & drivenm & "盘的总空间是:" & Format(Str(Val(hdspace) / 1024 / 1024), "##0.0") + " G" Label2.Caption = "你的" & drivenm & "盘剩余空间是:" & Format(Str(Val(hdfspace) / 1024), "###,##0.0") + " M" If UCase(Left(Drive1.Drive, 2)) = UCase(Left(cddrive, 2)) Then If Val(label1.Caption) = 0 And Val(Label2.Caption) = 0 Then MsgBox "这张盘是空的光盘" Else If Val(label1.Caption) > 0 And Val(Label2.Caption) > 0 Then MsgBox "这张盘不是空的光盘,但还有空间" Else If Val(label1.Caption) > 0 And Val(Label2.Caption) = 0 Then MsgBox "这张盘是写满并终止的光盘" End If End If End If End IfEnd Sub

窗体置前与取消 '添加 Command1Option ExplicitConst HWND_TOPMOST = -1Const HWND_NOTOPMOST = -2Private Declare Sub 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)Private Sub Form_Load() Command1.Caption = "窗体置前"End SubPrivate Sub Command1_Click() If Command1.Caption = "窗体置前" Then SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, 3 '设定总在最前 Command1.Caption = "取消置前" Else SetWindowPos Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, 3 '取消总在最前 Command1.Caption = "窗体置前" End IfEnd Sub

2进制与10进制转换 '添加 Text1 Command1 Command2Dim i&, j&Private Sub Form_Load() '比方说要将151转为二进制得到 10010111 '1,2,4,8,16,32,64,128(从右边往左算) Command1.Caption = "10转2" Command2.Caption = "2转10" Command1.Enabled = True Command2.Enabled = False Text1.Text = "151" Command1_ClickEnd SubPrivate Sub Command1_Click() '十进制转二进制 Text1.Text = ten2two(Val(Text1.Text)) Command1.Enabled = Not Command1.Enabled Command2.Enabled = Not Command2.EnabledEnd SubPrivate Sub Command2_Click() '二进制转十进制 Text1.Text = Trim(Str(two2ten(Text1.Text))) Command1.Enabled = Not Command1.Enabled Command2.Enabled = Not Command2.EnabledEnd SubFunction ten2two(ByVal tVlaue As Long) As String '十进制转二进制 ten2two = "" Do While tVlaue >= 1 ten2two = CStr(tVlaue Mod 2) & ten2two tVlaue = Int(tVlaue / 2) LoopEnd FunctionFunction two2ten(ByVal tstr As String) As Long '二进制转十进制 two2ten = 0 j = Len(Trim(tstr)) For i = 1 To j two2ten = IIf(Val(Mid(tstr, j - (i - 1), 1)) > 0, two2ten + 2 ^ (i - 1), two2ten) Next iEnd Function

屏蔽右上角的 X Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As LongPrivate Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As LongPrivate Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As LongConst MF_BYPOSITION = &H400&Const MF_REMOVE = &H1000&Private Sub Form_Load() Dim hSysMenu As Long, nCnt As Long hSysMenu = GetSystemMenu(Me.hwnd, False) If hSysMenu Then nCnt = GetMenuItemCount(hSysMenu) If nCnt Then RemoveMenu hSysMenu, nCnt - 1, MF_BYPOSITION Or MF_REMOVE DrawMenuBar Me.hwnd Me.Caption = "试着点X把我关掉吧,否则你只有点击我的身体啦!!" End If End IfEnd SubPrivate Sub Form_Click() Unload MeEnd Sub

窗体只剩最小化 '添加 Command1Private 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 Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As LongPrivate Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As LongConst MF_BYPOSITION = &H400&Const MF_REMOVE = &H1000&Sub Form_Load() Dim hSysMenu As Long Dim r%, j%, dw&, rr& Const MF_BYPOSITION = &H400 hSysMenu = GetSystemMenu(Me.hwnd, 0) For j = 8 To 4 Step -1 r = RemoveMenu(hSysMenu, j, MF_BYPOSITION) Next j dw& = GetWindowLong(Me.hwnd, -16) 'Window style dw& = dw& And &HFFFEFFFF 'Turn off bits for Maximize arrow button rr& = SetWindowLong(Me.hwnd, -16, dw&) Command1.Caption = "退出"End SubPrivate Sub Command1_Click() EndEnd Sub

确认是否要退出 '简单但是实用Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)Cancel = 1If MsgBox("是否要退出？", vbYesNo) = 6 Then EndEnd Sub

任务栏高度 Option ExplicitPrivate Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As LongConst SPI_GETWORKAREA = 48Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Sub Form_Load() MsgBox GetTaskbarHeight() * 15End SubPublic Function GetTaskbarHeight() As Integer Dim lRes As Long Dim rectVal As RECT lRes = SystemParametersInfo(SPI_GETWORKAREA, 0, rectVal, 0) GetTaskbarHeight = (Screen.Height / Screen.TwipsPerPixelX) - rectVal.BottomEnd Function

闪烁标题栏添加 Timer1Option ExplicitPrivate Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As LongPrivate Sub Form_Load() Timer1.Interval = 200End Sub'用一个时间控件，Interval设为200 ，这个闪烁的快慢Private Sub Timer1_Timer() Static mFlash As Boolean FlashWindow hwnd, Not mFlashEnd Sub

文件夹隐藏与显示添加 Command1 Command2'常数值描述'Normal 0 普通文件。未设置属性。'ReadOnly 1 只读文件。'Hidden 2 隐藏文件。'System 4 系统文件。Dim fname$, attrb&Private Sub Form_Load() Command1.Caption = "隐藏" Command2.Caption = "显示"End SubPrivate Sub Command1_Click() fname = "c:\kk" attrb = 2 Call Changeattr(fname, attrb)End SubPrivate Sub Command2_Click() fname = "c:\kk" attrb = 0 Call Changeattr(fname, attrb)End SubPrivate Sub Changeattr(folderspec$, attrno&) Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) f.Attributes = attrnoEnd Sub

检测网页是否已下载完毕 '添加 WebBrowser1, Text1Private Sub Form_Load() Text1.Text = "http://post.baidu.com/f?kz=204946905"End SubPrivate Sub Command1_Click() WebBrowser1.Navigate Text1.TextEnd SubPrivate Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant) If (pDisp Is WebBrowser1.Object) Then MsgBox "网页下载完毕!"End Sub

检测程序是否运行中 '添加 Command1Const TH32CS_SNAPHEAPLIST = &H1Const TH32CS_SNAPPROCESS = &H2Const TH32CS_SNAPTHREAD = &H4Const TH32CS_SNAPMODULE = &H8Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)Const TH32CS_INHERIT = &H80000000Const MAX_PATH As Integer = 260Private Type PROCESSENTRY32 dwSize As Long cntUsage As Long th32ProcessID As Long th32DefaultHeapID As Long th32ModuleID As Long cntThreads As Long th32ParentProcessID As Long pcPriClassBase As Long dwFlags As Long szExeFile As String * MAX_PATHEnd TypePrivate Declare Function CreateToolhelp32Snapshot Lib "Kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As LongPrivate Declare Function Process32First Lib "Kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As LongPrivate Declare Function Process32Next Lib "Kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As LongPrivate Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)Dim chkfile$, aa$, rPrivate Sub Form_Load() Me.AutoRedraw = True Call addjclistEnd SubPrivate Sub Command1_Click() Call addjclist chkfile = "Calc.exe" If InStr(aa, UCase(chkfile)) > 0 Then rtn = MsgBox("您确定要终止 " & procname & " 吗？", vbYesNo, "强制关闭进程") If rtn = 6 Then SendMessage hProcess, WM_CLOSE, 0, 0 '关闭此进程 End If Else MsgBox chkfile & " 没运行" End IfEnd SubSub addjclist() Dim hSnapShot As Long, uProcess As PROCESSENTRY32 hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&) uProcess.dwSize = Len(uProcess) r = Process32First(hSnapShot, uProcess) aa = "" Do While r aa = aa & Trim(uProcess.szExeFile) & " " r = Process32Next(hSnapShot, uProcess) Loop aa = UCase(aa) CloseHandle hSnapShotEnd Sub'************************** 代码 2 简单的方式Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 LongConst WM_CLOSE = &H10Dim hProcess&, procname$Private Sub Command1_Click() procname = "计算器" hProcess = FindWindow(vbNullString, procname) If hProcess > 0 Then rtn = MsgBox("您确定要终止 " & procname & " 吗？", vbYesNo, "强制关闭进程") If rtn = 6 Then SendMessage hProcess, WM_CLOSE, 0, 0 '关闭此进程 End If Else MsgBox procname & "没运行" End IfEnd Sub

添加删除系统用户添加 Command1 Command2 Text1 Text2Private Sub Command1_Click() Call Shell("net.exe user " & Text1.Text & " " & Text2.Text & " /add", vbHide) MsgBox "已新增使用者:" & Text1.Text Command1.Caption = "新增" Command2.Caption = "删除"End SubPrivate Sub Command2_Click() Call Shell("net.exe user " & Text1.Text & " /delete", vbHide) MsgBox "使用者:" & Text1.Text & " 已删除"End Sub

10进制与16进制转换 '添加 Text1 Command1 Command2 Dim rtn16 Private Sub Form_Load() Command1.Caption = "10转16" Command2.Caption = "16转10" Command1.Enabled = True Command2.Enabled = False Text1.Text = "65535" Command1_Click End Sub Private Sub Command1_Click() '十进制转十六进制 Text1.Text = Trim(Hex(Text1.Text) ) Command1.Enabled = Not Command1.Enabled Command2.Enabled = Not Command2.Enabled End Sub Private Sub Command2_Click() '十六进制转十进制 Text1.Text = IIf(CLng("&H" & Text1.Text) < 0, Trim(Str(CLng("&H" & Text1.Text) + 65536)), Trim(Str(CLng("&H" & Text1.Text)))) Command1.Enabled = Not Command1.Enabled Command2.Enabled = Not Command2.Enabled End Sub

滚动标题栏添加 Timer1Option ExplicitConst Captions As String = "CBM666的滚动标题栏"Dim N%, L%, C$Private Sub Form_Load() Timer1.Interval = 100End SubPrivate Sub Timer1_Timer() L = Int(Me.Width / 220) C = String(L, " ") & Captions & String(L, " ") N = N + 1 If N > Len(C) - L Then N = 1 Me.Caption = Mid(C, N, L)End Sub

Windows的系统路径 Dim aa$, bb$, jj%Private Sub Form_Load() aa = "Windows系统路径是: " & Environ("windir") & vbCrLf bb = Environ("comspec") jj = InStrRev(bb, "\") If jj > 0 Then aa = aa & "System32路径是: " & Mid(bb, 1, jj - 1) & vbCrLf aa = aa & "本机计算机名称: " & Environ("COMPUTERNAME") & vbCrLf aa = aa & "本机用户名: " & Environ("username") & vbCrLf aa = aa & "我的文件夹路径: " & Environ("USERPROFILE") MsgBox aaEnd Sub

托盘代码 Option ExplicitConst MAX_TOOLTIP As Integer = 64Const NIF_ICON = &H2Const NIF_MESSAGE = &H1Const NIF_TIP = &H4Const NIM_ADD = &H0Const NIM_DELETE = &H2Const WM_MOUSEMOVE = &H200Const WM_LBUTTONDOWN = &H201Const WM_LBUTTONUP = &H202Const WM_LBUTTONDBLCLK = &H203Const WM_RBUTTONDOWN = &H204Const WM_RBUTTONUP = &H205Const WM_RBUTTONDBLCLK = &H206Const SW_RESTORE = 9Const SW_HIDE = 0Private Type NOTIFYICONDATA cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * MAX_TOOLTIPEnd TypePrivate Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As LongPrivate Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPrivate nfIconData As NOTIFYICONDATAPrivate Sub Form_Load() nfIconData.hwnd = Me.hwnd nfIconData.uID = Me.Icon nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP nfIconData.uCallbackMessage = WM_MOUSEMOVE nfIconData.hIcon = Me.Icon.Handle nfIconData.szTip = "System Tray Example" & vbNullChar nfIconData.cbSize = Len(nfIconData) Call Shell_NotifyIcon(NIM_ADD, nfIconData) ShowWindow Me.hwnd, SW_HIDEEnd SubPrivate Sub Form_Unload(Cancel As Integer) Call Shell_NotifyIcon(NIM_DELETE, nfIconData) EndEnd SubPrivate Sub Form_Resize() If Me.WindowState = 1 Then nfIconData.hwnd = Me.hwnd nfIconData.uID = Me.Icon nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP nfIconData.uCallbackMessage = WM_MOUSEMOVE nfIconData.hIcon = Me.Icon.Handle nfIconData.szTip = Form1.Caption & vbNullChar nfIconData.cbSize = Len(nfIconData) Call Shell_NotifyIcon(NIM_ADD, nfIconData) ShowWindow Me.hwnd, SW_HIDE End IfEnd SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lMsg As Single lMsg = X / Screen.TwipsPerPixelX If lMsg = WM_RBUTTONUP Or lMsg = WM_LBUTTONUP Then Me.WindowState = 0 Me.Show End IfEnd Sub

每隔10秒定时提取保存网页内容 '添加Command1 Timer1 inet1Private Declare Function GetTickCount& Lib "kernel32" ()Dim aa$, fname$, seqno%, starttm&, a(3) As StringPrivate Sub Form_Load() a(1) = "http://www.baidu.com/" a(2) = "http://blog.csdn.net/eako/archive/2004/12/17/219422.aspx" a(3) = "http://www.sina.com/" Timer1.Interval = 500 Timer1.Enabled = False Me.ClsEnd SubPrivate Sub Command1_Click() seqno = 1 starttm = GetTickCount Timer1.Enabled = TrueEnd SubPrivate Sub Timer1_Timer() If GetTickCount - starttm >= 10000 Then '每隔10秒 fname = "d:\" & Format(Year(Now), "####") & Format(Month(Now), "00") & Format(Day(Now), "00") & Format(Str(seqno), "00") & ".txt" aa = Inet1.OpenURL(a(seqno)) Open fname For Output As #1 Print #1, aa Close #1 Print "已保存第" & Str(seqno) & " 个网页" starttm = GetTickCount seqno = seqno + 1 If seqno > 3 Then End End IfEnd Sub

闰年与平年一般被4整除的为润年但是...... 能被4整除但不能被100整除的为润年, 能被400整除的为润年 '添加 Text1Private Sub Form_Load() Text1.Text = "2000" End Sub Private Sub Command1_Click() yearb = Val(Text1.Text) If (yearb Mod 4 = 0 And yearb Mod 100 <> 0) Or (yearb Mod 400 = 0) Then MsgBox "润年" Else MsgBox "平年" End If End Sub

隐藏左下角的开始添加Command1Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPrivate Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongConst SW_HIDE = 0Const SW_SHOW = 5Dim bx As BooleanPrivate Sub Form_Load() Command1.Caption = "隐藏"End SubPrivate Sub Form_Unload(Cancel As Integer) If bx Then command1_Click EndEnd SubPrivate Sub command1_Click() Dim hLong&, hwnd& hwnd = FindWindow("Shell_TrayWnd", vbNullString) hLong = FindWindowEx(hwnd, 0, "Button", vbNullString) If bx Then ShowWindow hLong, SW_SHOW bx = False Command1.Caption = "隐藏" Else ShowWindow hLong, SW_HIDE bx = True Command1.Caption = "显示" End IfEnd Sub

读取键盘 NumLock 、CapsLock、ScrollLock 电灯的值添加 Command1Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As IntegerDim aa$, bb$Private Sub Command1_Click() aa = "Num灯:" bb = IIf(GetNumlock, "点亮", "熄灭") aa = aa & bb & vbCrLf aa = aa & "Caps灯:" bb = IIf(GetCapslock, "点亮", "熄灭") aa = aa & bb & vbCrLf aa = aa & "Scroll灯:" bb = IIf(GetScrollLock, "点亮", "熄灭") aa = aa & bb & vbCrLf MsgBox aaEnd SubFunction GetCapslock() As Boolean '返回 Capslock 的状态 GetCapslock = CBool(GetKeyState(vbKeyCapital) And 1)End FunctionFunction GetNumlock() As Boolean GetNumlock = CBool(GetKeyState(vbKeyNumlock) And 1)End FunctionFunction GetScrollLock() As Boolean '返回 ScrollLock 的状态 GetScrollLock = CBool(GetKeyState(vbKeyScrollLock) And 1)End Function

动态ANI光标 **********************************动态ANI光标函数 Private Const GCL_HCURSOR& = (-12) Private Declare Function SetClassLong& Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) Private Declare Function LoadCursorFromFile& Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) Private NewCursor1 As Long Private OldCursor1 As Long Private Sub Form_Load() '**********************************设置动态ANI光标 '下面这个dino1.ani是我的光标,当然你要把它改成你自己路径下的光标文件名称 NewCursor1 = LoadCursorFromFile("c:\bawang\bwimg\dinol.ani") OldCursor1 = SetClassLong(Me.hwnd, GCL_HCURSOR, NewCursor1) End Sub Private Sub Form_Activate() MsgBox "你现在看到的是一般的白色箭头光标,按下确定后,你就能看到你设定的动态光标,按下任何键退出时,取消动态光标!!" End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii <> 0 Then Unload Me End Sub Private Sub Form_Unload(Cancel As Integer) '**********************************取消动态ANI光标 SetClassLong Me.hwnd, GCL_HCURSOR, OldCursor1 End End Sub

鼠标限制添加 Picture1 Command1 Command2Option ExplicitPrivate Type RECT left As Long top As Long right As Long bottom As LongEnd Type' 以下几个函数均用API申明Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As LongPrivate Declare Function ClipCursor Lib "user32" (lpRect As Any) As LongPrivate Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPrivate Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As LongConst SM_CYCAPTION = 4Const SM_CXFRAME = 32Const SM_CYFRAME = 33Dim x1%, y1%Dim r As RECTPrivate Sub Form_Load() Command1.Caption = "将鼠标限制在PictureBox内" Command2.Caption = "将鼠标限制在窗体内" Picture1.AutoRedraw = True Picture1.Width = 2000 Picture1.Print "在图片匡内双击释放鼠标" Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 SetCursorPos (Me.left + Me.Width \ 2) \ 15, (Me.top + Me.Height \ 2) \ 15End SubPrivate Sub Form_Unload(Cancel As Integer) ReleaseEnd Sub' 将鼠标限制在PictureBox内Private Sub Command1_Click() RestrictToControl Picture1 'RestrictToControl在模块程序中有定义 CenterOnControl Picture1End Sub'将鼠标限制在窗体内Private Sub Command2_Click() RestrictToForm Me CenterOnForm MeEnd Sub' 双击鼠标左键释放光标Private Sub Picture1_DblClick() Call ReleaseEnd SubPrivate Sub Release() Call ClipCursor(ByVal vbNullString)End SubPrivate Sub RestrictToControl(cntl As Control) On Error Resume Next Call GetWindowRect((cntl.hwnd), r) If Err.Number = 0 Then Call RestrictToRect(r) End IfEnd SubPrivate Sub CenterOnControl(cntl As Control) On Error Resume Next Call GetWindowRect((cntl.hwnd), r) If Err.Number = 0 Then CenterOnRect r End IfEnd SubPrivate Sub CenterOnForm(frm As Form) Call GetClientScrnRect(frm, r) Call CenterOnRect(r)End SubPrivate Sub RestrictToForm(frm As Form) Call GetClientScrnRect(frm, r) Call RestrictToRect(r)End SubPrivate Sub RestrictToRect(lpRect As RECT) Call ClipCursor(lpRect)End SubPrivate Sub CenterOnRect(lpRect As RECT) Call SetCursorPos(lpRect.left + (lpRect.right - lpRect.left) \ 2, lpRect.top + (lpRect.bottom - lpRect.top) \ 2)End SubPrivate Sub GetClientScrnRect(frm As Form, rC As RECT) Call GetWindowRect((frm.hwnd), rC) x1 = GetSystemMetrics(SM_CXFRAME) y1 = GetSystemMetrics(SM_CYFRAME) rC.left = rC.left + x1 rC.right = rC.right - x1 rC.top = rC.top + y1 + GetSystemMetrics(SM_CYCAPTION) rC.bottom = rC.bottom - y1End Sub

CBM666 的隐藏桌面图标添加 Command1 Command2Option ExplicitPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As LongConst SW_HIDE = 0Const SW_RESTORE = 9Dim Hwd&, rtn&Private Sub Form_Load() Command1.Caption = "隐藏" Command2.Caption = "回复"End SubPrivate Sub Form_Unload(Cancel As Integer) Command2_ClickEnd SubPrivate Sub Command1_Click() Hwd = FindWindow("Progman", vbNullString) rtn = ShowWindow(Hwd, SW_HIDE)End SubPrivate Sub Command2_Click() Hwd = FindWindow("Progman", vbNullString) rtn = ShowWindow(Hwd, SW_RESTORE)End Sub

隐藏任务栏 '添加 Command1 Command2Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function SetWindowPos Lib "user32.dll" (ByVal lhwnd As Long, ByVal hWndInsertAfter As Long, ByVal swpX As Long, ByVal swpY As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As LongConst swp_HideWindow = &H80Const swp_ShowWindow = &H40Dim task%, TaskbarHwn&Private Sub Form_Load() Command1.Caption = "关闭任务栏" Command2.Caption = "显示任务栏"End SubPrivate Sub Form_Unload(Cancel As Integer) Command2_ClickEnd SubPublic Sub taskclick() TaskbarHwn = FindWindow("Shell_traywnd", "") If task = 1 Then Call SetWindowPos(TaskbarHwn, 0, 0, 0, 0, 0, swp_HideWindow) Else Call SetWindowPos(TaskbarHwn, 0, 0, 0, 0, 0, swp_ShowWindow) End IfEnd SubPrivate Sub Command1_Click() task = 1 '1 关闭任务栏 taskclickEnd SubPrivate Sub Command2_Click() task = 2 '2 显示任务栏 taskclickEnd Sub

鼠标位置与定位 '添加 Timer1 Label1Private Type POINTAPI x As Long y As LongEnd TypePrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPrivate Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As LongPrivate Sub Form_Load() Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 SetCursorPos (Me.Left + Me.Width \ 2) \ 15, (Me.Top + Me.Height \ 2) \ 15 Timer1.Interval = 100End SubPrivate Sub Timer1_Timer() Dim Point As POINTAPI GetCursorPos Point Label1.Caption = Point.x & " " & Point.yEnd Sub

关闭一个运行中的程序进程 Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As LongConst PROCESS_TERMINATE = 1Dim AA$, ProID&, hProcess&Private Sub Form_Load() '下面这个路径你要自己改 AA = "c:\test.exe" If Dir(AA) <> "" Then ProID = Shell(AA, 3) SendKeys (Chr(13)) End IfEnd SubPrivate Sub Form_Unload(Cancel As Integer) AA = "c:\test.exe" If Dir(AA) <> "" Then hProcess = OpenProcess(PROCESS_TERMINATE, False, ProID) TerminateProcess hProcess, 1 CloseHandle hProcess End If EndEnd Sub

以滚动条完全显示图片 '添加Picture1 Picture2 HScroll1 VScroll1'将一张图片与你的程序摆在同路径,并将bwtruck.jpg改为你自己的图片名称Option ExplicitDim appdisk$Private Sub Form_Load() appdisk = Trim(App.Path) If Right(appdisk, 1) <> "\" Then appdisk = appdisk & "\" Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 Picture1.BorderStyle = 0 Picture2.BorderStyle = 0 Picture2.AutoSize = True Picture2.Picture = LoadPicture(appdisk & "bwtruck.jpg") HScroll1.Height = 350 HScroll1.SmallChange = 100 HScroll1.LargeChange = 200 VScroll1.Width = 350 VScroll1.SmallChange = 100 VScroll1.LargeChange = 200 HScroll1.ZOrder 0 VScroll1.ZOrder 0End SubPrivate Sub Form_Resize() Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height Picture2.Move 0, 0 HScroll1.Move 0, Picture1.Height, Picture1.Width HScroll1.Max = Picture2.Width - Picture1.Width HScroll1.Visible = (Picture2.Width > Picture1.Width) VScroll1.Move Picture1.Width, 0, VScroll1.Width, Picture1.Height VScroll1.Max = Picture2.Height - Picture1.Height VScroll1.Visible = (Picture2.Height > Picture1.Height)End SubPrivate Sub HScroll1_Change() Picture2.Left = -HScroll1.ValueEnd SubPrivate Sub HScroll1_Scroll() Picture2.Left = -HScroll1.ValueEnd SubPrivate Sub VScroll1_Change() Picture2.Top = -VScroll1.ValueEnd SubPrivate Sub VScroll1_Scroll() Picture2.Top = -VScroll1.ValueEnd Sub

开机自动启动程序 ************ 方法 1 写进「开始」菜单\程序\启动Dim aa$, bb$ Private Sub Command1_Click() aa = "c:\windows\abc.exe" bb = Environ("userprofile") & "\「开始」菜单\程序\启动\abc.exe" FileCopy aa, bb End Sub '******************* 方法 2 写进注册表的方法 1.这个是使用注册表方式. 2.下面这代码,我已在win2000下跑过没问题,但在98或winme,XP我就没试过了, '使用下面这三个API与两个常数(标记部份为快捷键方式增加到开始下的启动) Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Const HKEY_LOCAL_MACHINE = &H80000002 Const REG_SZ = 1 Private Sub Command1_Click() Dim Ret2 As Long '打开 HKEY_LOCAL_MACHINE　下的　software\microsoft\windows\currentVersion\run RegCreateKey HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", Ret2 '将此主键下的 "默认" 值改为你的 exe 全路径" RegSetValue Ret2, vbNullString, REG_SZ, "c:\windows\abc.exe", 4 '关闭对主键的操作 RegCloseKey Ret2 End Sub

文字上卷特效 Option ExplicitDim CurY As SinglePrivate Sub Command1_Click() CurY = Picture1.Height Timer1.Enabled = TrueEnd SubPrivate Sub Form_Load() Dim s As String, nl As String * 2 Timer1.Enabled = False Picture1.BackColor = QBColor(0) ' Black Text1.BackColor = RGB(0, 0, 0) ' Black 'Text1.ForeColor = &HFF0000 ' Blue nl = Chr$(13) + Chr$(10) Text1 = "" Open App.Path + "\test.txt" For Input As #1 While Not EOF(1) Line Input #1, s Text1 = Text1 + s + nl Wend Close #1 Text1.Font.Size = 12 Set Font = Text1.Font Text1.Move 0, Picture1.Height Text1.Width = Picture1.Width Text1.Height = TextHeight(Text1.Text)End SubPrivate Sub Timer1_Timer() Text1.Top = CurY CurY = CurY - 25 If CurY + Text1.Height < 0 Then CurY = Picture1.Height End IfEnd Sub

制作卸载程序（VB很实用的，因为它带的安装程序安装完后没有卸载功 On Error GoTo BaddUnDim X&Dim buffer As String * 128Dim UnStr As StringDim size As IntegerDim retval As Integerbuffer = Space$(128)size = 128retval = GetWindowsDirectory(ByVal buffer, ByVal size)Me.Caption = bufferUnStr = Me.Caption & "\ST6UNST.EXE -n " & Chr(34) & App.Path & "\ST6UNST.LOG" & Chr(34)X& = Shell(UnStr, vbNormalFocus)Unload MeExit SubBaddUn:MsgBox "发生意外错误！", vbCriticalExit Sub

制作下雪效果（只用一个timer控件） Dim Snow(1000, 2), Amounty As IntegerPrivate Sub Form_Load()Form1.ShowDoEventsRandomize: Amounty = 325For J = 1 To AmountySnow(J, 0) = Int(Rnd * Form1.Width)Snow(J, 1) = Int(Rnd * Form1.Height)Snow(J, 2) = 10 + (Rnd * 20)Next JDo While Not (DoEvents = 0)For LS = 1 To 10For I = 1 To AmountyOldX = Snow(I, 0): OldY = Snow(I, 1): Snow(I, 1) = Snow(I, 1) + Snow(I, 2)If Snow(I, 1) > Form1.Height Then Snow(I, 1) = 0: Snow(I, 2) = 5 + (Rnd * 30): Snow(I, 0) = Int(Rnd * Form1.Width): OldX = 0: OldY = 0Coloury = 8 * (Snow(I, 2) - 10): Coloury = 60 + Coloury: PSet (OldX, OldY), QBColor(0): PSet (Snow(I, 0), Snow(I, 1)), RGB(Coloury, Coloury, Coloury)Next INext LSLabel1.RefreshLoopEndEnd SubPrivate Sub Timer1_Timer()Label1.ForeColor = RGB(Rnd() * 265, Rnd() * 255, Rnd() * 345)End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)EndEnd Sub

制作30次试用版 Private Sub Form_Load()Dim RemainDay As LongRemainDay = GetSetting("MyApp", "set", "times", 0)If RemainDay = 10 ThenMsgBox "试用次数已满，请……"Unload MeEnd IfMsgBox "现在剩下：" & 10 - RemainDay & "试用次数，好好珍惜！"RemainDay = RemainDay + 1SaveSetting "MyApp", "set", "times", RemainDayEnd Sub

制作30天试用版 Private Sub Form_Load()Dim RemainDay As LongRemainDay = GetSetting("MyApp", "set", "day", 0)If RemainDay = 30 ThenMsgBox "试用期已过，请……"Unload MeEnd IfMsgBox "现在剩下：" & 30 - RemainDay & "试用天数，好好珍惜！"If Day(Now) - RemainDay > 0 Then RemainDay = RemainDay + 1SaveSetting "MyApp", "set", "times", RemainDayEnd Sub

一组实用代码用VB实现编程离不开函数调用及Windows API函数的调用，以下是笔者收集的一些实用的小例程，它们可以直接用在你的实际编程中，也可以根据实际应用加以扩充完善。其中涉及Windows API函数调用的代码你可以从VB5.0系统的API函数查看器中复制函数定义内容，以避免出错。 1.系统型表单系统型意味着用户完成当前表单操作之前无法进行其它操作，这对于编制系统口令保护界面尤为重要。如果你希望当前表单系统型表单，需如下定义API函数：Declare Function SetSysModalWindow Lib "User" (ByVal hWnd As Integer) As Integer然后调用：oldSysModal = SetSysModalWindow([Form].hWnd) 2.获取驱动器类型代码如后：Declare Function GetDriveType Lib “Kernel" (ByVal nDrive As Integer) As IntegerGlobal Const DRIVE_REMOVEABLE％ = 2, DRIVE_FIXED％ = 3Global Const DRIVE_REMOTE％ = 4 3.表单在对中本子程序功能使表单定位在屏幕中央，在表单中任何需要表单对中的地方只需加入一行代码：“centerwindow.me”即可成功调用。Public Sub CenterWindow(f As Form)f.Top = (Screen.Height ＊ .5) － (f.Height ＊ .5)f.Left = (Screen.Width ＊ .5) － (f.Width ＊ .5)End Sub 4. 定义变量许多的程序员习惯于如下定义变量：Dim iNum, iNextNum, iLastNum as Integer 实际上只有最后一个变量被设为了整型，前两个变量则是系统的缺省的Variant 数据类型，而Variant 数据类型可用来替换任何数据类型，显然对于精练的程序设计是不利的。正确的方法如下： Dim iNum as Integer Dim iNextNum as Integer Dim iLastNum as Integer 5. 使文本高亮本子程序使被触发的诸如文本，标签等控件的文本被选中Public Sub SetSelected()Screen.ActiveControl.SelStart = 0Screen.ActiveControl.SelLength = Len(Screen.ActiveControl.Text)End Sub 6. 关闭其它程序下面的代码可关闭内存中的其它程序title = "MyAPP" '定义你需关闭的程序窗口的标题ihWnd = findWindow(0＆, Title)ihTask = GetWindowTask (ihWnd)iRet = PostAppMessage(ihTask, WM_QUIT, 0, 0＆) 7. 文件存在否? 本函数返回查找的文件是否存在。Function FileExist(Filename as string) as BooleanFileExist = IIf(Dir(Filename) <> "", True, False)End Function 8. 主程序唯一用下面提供的代码作你的主程序可防止应用程序的多重执行，你应当将它放在确信需要它的代码模块内。Public Sub Main()If App.PrevInstance ThenBringWindowToTop frmMain.hwnd ElseLoad frmMainEnd IfEnd Sub 上面这些精悍的代码对于专业程序员来说非常有实用价值，希望你能从中获得启发。　

文字上卷 Option ExplicitPrivate Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPrivate Declare Function GetTickCount Lib "kernel32" () As LongConst DT_BOTTOM As Long = &H8Const DT_CALCRECT As Long = &H400Const DT_CENTER As Long = &H1Const DT_EXPANDTABS As Long = &H40Const DT_EXTERNALLEADING As Long = &H200Const DT_LEFT As Long = &H0Const DT_NOCLIP As Long = &H100Const DT_NOPREFIX As Long = &H800Const DT_RIGHT As Long = &H2Const DT_SINGLELINE As Long = &H20Const DT_TABSTOP As Long = &H80Const DT_TOP As Long = &H0Const DT_VCENTER As Long = &H4Const DT_WORDBREAK As Long = &H10Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypeConst ScrollText As String = "My Application Title" & vbCrLf & _ vbCrLf & vbCrLf & _ "Producer: Myself" & vbCrLf & _ "Executive Producer: Myself" & _ vbCrLf & "Main programmer: Myself" & _ vbCrLf & "Main graphic artist: Myself" & _ vbCrLf & vbCrLf & _ "Sample from:" & _ vbCrLf & _ "HTTP://WWW.VBEXPLORER.COM" Dim EndingFlag As BooleanPrivate Sub Form_Activate()RunMainEnd SubPrivate Sub Form_Load()picScroll.ForeColor = vbYellowpicScroll.FontSize = 14End SubPrivate Sub RunMain()Dim LastFrameTime As LongConst IntervalTime As Long = 40Dim rt As LongDim DrawingRect As RECTDim UpperX As Long, UpperY As LongDim RectHeight As LongfrmAbout.Refreshrt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT)If rt = 0 Then MsgBox "Error scrolling text", vbExclamation EndingFlag = TrueElse DrawingRect.Top = picScroll.ScaleHeight DrawingRect.Left = 0 DrawingRect.Right = picScroll.ScaleWidth RectHeight = DrawingRect.Bottom DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeightEnd IfDo While Not EndingFlag If GetTickCount() - LastFrameTime > IntervalTime Then picScroll.Cls DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER Or DT_WORDBREAK DrawingRect.Top = DrawingRect.Top - 1 DrawingRect.Bottom = DrawingRect.Bottom - 1 If DrawingRect.Top < -(RectHeight) Then DrawingRect.Top = picScroll.ScaleHeight DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight End If picScroll.Refresh LastFrameTime = GetTickCount() End If DoEventsLoopUnload MeSet frmAbout = NothingEnd Sub****************主窗体********************Option ExplicitPrivate Sub mnuHelpAbout_Click()frmAbout.Show vbModal, MeEnd Sub

[原创]使VB编辑器支持滚轮来VB吧这么长时间了，做点贡献，做了一个使VB编程器支持滚轮的dll文件，由于永硕网络硬盘速度太慢，要的大家留邮箱，我有时间发给大家。

如何限定密码登陆框中密码的个数 textbox有一个length参数Text1.MaxLength = 5

获得MouseLeave的方法 VB中缺少一个MouseLeave事件，给编程带来许多不便。例如，当我们想令鼠标移动到一个命令按钮时令其Caption属性为一个名称，离开时又是另一个名称，我们通常只能这么处理：用两个MouseMove事件：一个是命令按钮的，另一个可能是窗体的，也可能是命令按钮周边的其它控件的。——这无疑很麻烦，而且当控件较为紧凑时往往达不到预期的目的。有没有什么办法可以判断鼠标已经从某一个控件中移走呢？请看下面的例子。在标准EXE工程中缺省创建一个TextBox，然后键入以下代码：Option Explicit'申明API函数——Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function ReleaseCapture Lib "user32" () As Long'通过Text1的MouseMove事件判断鼠标指针位置Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim MouseLeave As BooleanMouseLeave = (0 <= X) And (X <= Text1.Width) And (0 <= Y) And (Y <= Text1.Height)If MouseLeave ThenText1 = "Inside"SetCapture Text1.hWndElseText1 = "Outside"ReleaseCaptureEnd IfEnd Sub运行程序，把鼠标移到Text1，Text1显示：Inside，移开则显示：Outside，可见已经达到目的了。此法适合于一切具有hWnd属性的控件（如下所列）：ProgressBar控件，Slider控件，StatusBar控件，TabStrip控件，ToolbarControl，Animation控件，UpDown控件，DBCombo控件，DBList控件，SSTab控件，PicturtClip控件，RichTextBox控件，PropertyPage对象，UserControl对象，UserDocument对象，CheckBox控件，ComboBox控件，CommandButton控件，DirListBox控件，DriveListBox控件，FileListBox控件，Form对象，Forms集合，Frame控件，HscrollBar，VScrollBar控件，ListBox控件，MDIForm对象，OptionButton控件，PictureBox控件，TextBox控件，OLEContainer控件。

将ENTER变成TAB键 Public Const VK_TAB = &H9Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then KeyAscii = 0 keybd_event VK_TAB, 0, 0, 0 End IfEnd Sub

创建无 Icon 的窗口我们在很多时候都需要那种无 Icon 的窗口，如“关于……”“查找”等。在 VB 中，我们可以按以下步骤来创建此类窗口： 1、设置窗口的 BorderStyle = 3； 2、在 Form_Load 中加入：Me.Icon = LoadPicture("")

让窗体居中在主窗体的Form_load()中的最前面加入下列代码：Dim X0 As longDim Y0 As Long'让窗体居中X0 = Screen.WidthY0 = Screen.HeightX0 = (X0 - Me.Width) / 2Y0 = (Y0 - Me.Height) / 2Me.Move X0, Y0

KeyCode常数用法可在代码中的任何地方用下列常数代替实际值：常数值描述vbKeyLButton 0x1 鼠标左键vbKeyRButton 0x2 鼠标右键vbKeyCancel 0x3 CANCEL 键vbKeyMButton 0x4 鼠标中键vbKeyBack 0x8 BACKSPACE 键vbKeyTab 0x9 TAB 键vbKeyClear 0xC CLEAR 键vbKeyReturn 0xD ENTER 键vbKeyShift 0x10 SHIFT 键vbKeyControl 0x11 CTRL 键vbKeyMenu 0x12 MENU 键vbKeyPause 0x13 PAUSE 键vbKeyCapital 0x14 CAPS LOCK 键vbKeyEscape 0x1B ESC 键vbKeySpace 0x20 SPACEBAR 键vbKeyPageUp 0x21 PAGE UP 键vbKeyPageDown 0x22 PAGE DOWN 键vbKeyEnd 0x23 END 键vbKeyHome 0x24 HOME 键vbKeyLeft 0x25 LEFT ARROW 键vbKeyUp 0x26 UP ARROW 键vbKeyRight 0x27 RIGHT ARROW 键vbKeyDown 0x28 DOWN ARROW 键vbKeySelect 0x29 SELECT 键vbKeyPrint 0x2A PRINT SCREEN 键vbKeyExecute 0x2B EXECUTE 键vbKeySnapshot 0x2C SNAPSHOT 键vbKeyInsert 0x2D INSERT 键vbKeyDelete 0x2E DELETE 键vbKeyHelp 0x2F HELP 键vbKeyNumlock 0x90 NUM LOCK 键A 至 Z 键与 A 杴 Z 字母的 ASCII 码相同：常数值描述vbKeyA 65 A 键vbKeyB 66 B 键vbKeyC 67 C 键vbKeyD 68 D 键vbKeyE 69 E 键vbKeyF 70 F 键vbKeyG 71 G 键vbKeyH 72 H 键vbKeyI 73 I 键vbKeyJ 74 J 键vbKeyK 75 K 键vbKeyL 76 L 键vbKeyM 77 M 键vbKeyN 78 N 键vbKeyO 79 O 键vbKeyP 80 P 键vbKeyQ 81 Q 键vbKeyR 82 R 键vbKeyS 83 S 键vbKeyT 84 T 键vbKeyU 85 U 键vbKeyV 86 V 键vbKeyW 87 W 键vbKeyX 88 X 键vbKeyY 89 Y 键vbKeyZ 90 Z 键0 至 9 键与数字 0 杴 9 的 ASCII 码相同：常数值描述vbKey0 48 0 键vbKey1 49 1 键vbKey2 50 2 键vbKey3 51 3 键vbKey4 52 4 键vbKey5 53 5 键vbKey6 54 6 键vbKey7 55 7 键vbKey8 56 8 键vbKey9 57 9 键下列常数代表数字键盘上的键：常数值描述vbKeyNumpad0 0x60 0 键vbKeyNumpad1 0x61 1 键vbKeyNumpad2 0x62 2 键vbKeyNumpad3 0x63 3 键vbKeyNumpad4 0x64 4 键vbKeyNumpad5 0x65 5 键vbKeyNumpad6 0x66 6 键vbKeyNumpad7 0x67 7 键vbKeyNumpad8 0x68 8 键vbKeyNumpad9 0x69 9 键vbKeyMultiply 0x6A MULTIPLICATION SIGN (*) 键vbKeyAdd 0x6B PLUS SIGN (+) 键vbKeySeparator 0x6C ENTER 键vbKeySubtract 0x6D MINUS SIGN (杴) 键vbKeyDecimal 0x6E DECIMAL POINT (.) 键vbKeyDivide 0x6F DIVISION SIGN (/) 键下列常数代表功能键：常数值描述vbKeyF1 0x70 F1 键vbKeyF2 0x71 F2 键vbKeyF3 0x72 F3 键vbKeyF4 0x73 F4 键vbKeyF5 0x74 F5 键vbKeyF6 0x75 F6 键vbKeyF7 0x76 F7 键vbKeyF8 0x77 F8 键vbKeyF9 0x78 F9 键vbKeyF10 0x79 F10 键vbKeyF11 0x7A F11 键vbKeyF12 0x7B F12 键vbKeyF13 0x7C F13 键vbKeyF14 0x7D F14 键vbKeyF15 0x7E F15 键vbKeyF16 0x7F F16 键

VB常见问题解答(1) 问：在一个床体中设置了2个命令按钮，Command1，Command2。Commamd1执行一个费时的操作，包括调用多个过程和函数，而Command2则是终止/暂停Command1的运行，不是退出该程序，不知用VB5.0如何解决?答：你可以采用一种变通的方法，在程序中定义一个Boolean变量，在执行command1中的程序时监视该变量，如果为False退出程序，在command2中加入代码，只要点击command2就将该变量设置为False下面是例程Dim bMark As BooleanPrivate Sub Command1_Click()bMark = TrueFor I = 1 To 150000 ' Start loop.DoEvents ' Yield to operating system.Text1.Text = Str(I)If Not bMark ThenExit SubEnd IfNext I ' Increment loop counterEnd SubPrivate Sub Command2_Click()bMark = FalseEnd Sub问：有位大侠编了如下代码:Private Sub cmdCalendar_Click()Dim UserDate As DateUserDate = CVDate(txtDate)If frmCalendar.GetDate(UserDate) ThentxtDate = UserDateEnd IfEnd Sub-

ODBC API 的VB Sample Example: Private Sub Command1()Dim a_hEnv As LongDim a_hDBC As LongDim s_District As LongDim u_District As Long Dim Query As StringDim aToken As LongDim Ret As Integer Dim s_parm1(256) As ByteDim s_parm2 As IntegerDim s_parm3(256) As ByteDim s_parm4 As IntegerDim aDTax As SingleDim aNextOrder As IntegerDim bNextOrder As IntegerDim cbValue1 As LongDim cbValue2 As LongDim cbValue3 As LongDim cbValue4 As LongDim cbValue5 As LongDim i As Integer’ Variables that hold the length of the parameters cbValue1 = SQL_NTS cbValue2 = 0 cbValue3 = SQL_NTS cbValue4 = 0 cbValue5 = 0’ Connect to an AS/400 Ret = SQLAllocEnv(a_hEnv) ’ Allocates the SQL environment Ret = SQLAllocConnect(a_hEnv, a_hDBC) ’ Allocates connection Ret = SQLConnect(a_hDBC, "BANANA", SQL_NTS, "SPEED", SQL_NTS, "SPEED2", SQL_NTS)’ Create a prepared statement to select data Ret = SQLAllocStmt(a_hDBC, s_District) Query = "Select DTAX, DNXTOR from QUSER.DSTRCT where (DWID=? and DID=?)" Ret = SQLSetStmtOption(s_District, SQL_CONCURRENCY, SQL_CONCUR_READ_ONLY) Ret = SQLPrepare(s_District, Query, SQL_NTS) ’ Bind the parameters for the select query Ret = SQLBindParameter(s_District, 1, SQL_PARAM_INPUT, SQL_C_CHAR, SQL_CHAR, 4, 0, s_parm1(0), 0, cbValue1) Ret = SQLBindParameter(s_District, 2, SQL_PARAM_INPUT, SQL_C_SSHORT, SQL_INTEGER, 3, 0, s_parm2, 0, cbValue2) Ret = SQLBindCol(s_District, 1, SQL_C_FLOAT, aDTax, 0, 0&) Ret = SQLBindCol(s_District, 2, SQL_C_SSHORT, aNextOrder, 0, 0&)’ Create a prepared statement to update data Ret = SQLAllocStmt(a_hDBC, u_District) Query = "Update DSTRCT set DNXTOR=? where (DWID=? and DID=?)" Ret = SQLPrepare(u_District, Query, SQL_NTS)’ Bind the parameters for the Update query Ret = SQLBindParameter(u_District, 1, SQL_PARAM_INPUT, SQL_C_SSHORT, SQL_INTEGER, 0, 0, bNextOrder, 0, cbValue5) Ret = SQLBindParameter(u_District, 2, SQL_PARAM_INPUT, SQL_C_CHAR, SQL_CHAR, 4, 0, s_parm3(0), 0, cbValue3) Ret = SQLBindParameter(u_District, 3, SQL_PARAM_INPUT, SQL_C_SSHORT, SQL_INTEGER, 3, 0, s_parm4, 0, cbValue4)’ You should not pass character pointers to DLL’s so we convert them to’ byte arrays (actually from Unicode charater strings to byte arrays) Call StringToBytes("0001", 256, s_parm1()) ’ Warehouse Call StringToBytes("0001", 256, s_parm3()) ’ Warehouse’ This loop will increment a field in ten different rows For i = 1 To 10’ Set the parameters s_parm2 = i ’ District s_parm4 = i ’ District’ Execute the select query. Ret = SQLExecute(s_District)’ Fetch results. Ret = SQLFetch(s_District) Ret = SQLFreeStmt(s_District, SQL_CLOSE)’ Do some processing of this row...’ Then increment the field bNextOrder = aNextOrder + 1’ Execute the update Ret = SQLExecute(u_District) Ret = SQLFreeStmt(u_District, SQL_CLOSE) Next’ Free the ODBC resources Ret = SQLFreeStmt(s_District, SQL_DROP) Ret = SQLFreeStmt(u_District, SQL_DROP) Ret = SQLDisconnect(a_hDBC) ’ Disconnecting and deallocating. Ret = SQLFreeConnect(a_hDBC) Ret = SQLFreeEnv(a_hEnv)End SubPrivate Function BytesToString(byte_array() As Byte) As String’ convert byte array to string.Dim Data As String, StrLen As String Data = StrConv(byte_array(), vbUnicode) StrLen = InStr(Data, Chr(0)) - 1 BytesToString = Left(Data, StrLen)End FunctionPrivate Sub StringToBytes(Data As String, ByteLen As Integer, return_buffer() As Byte)’ convert string to byte array.Dim StrLen As Integer, Count As Integer For Count = 0 To Len(Data) - 1 return_buffer(Count) = Asc(Mid(Data, Count + 1, 1)) Next Count For Count = Len(Data) To ByteLen return_buffer(Count) = 0 Next CountEnd Sub

感悟VB API 编写VB程序时，经常遇到的问题就是VB给我们准备的东西我们会用，控件组装就是一个程序，然而一旦想要实现VB没有直接提供的功能，就会不知所措。其实Windows操作系统本身就给我们准备了许多东西，VB没有的，或许Windows有。我们当然希望少花力气，多得效果。这里要讲的内容就是——学会利用Windows给我们的东西:API。　　然而，学会一种东西是需要付出相当的努力的，API也一样，它可以给我们带来很大的方便，但想要掌握它，就不是使用几个控件那么轻松的事了。所以在看这篇文章时，希望读者可以抱一个正确的态度，就是学习编程不是为好玩，而是为使用; 不要以自己对这方面是否有兴趣而看，而要为API是否能为你的程序带来效果而看。我并不是说一切都是那么严肃和困难，只是API对VB来说，已经可以算高级方面的应用了，所以“认真”和“仔细”是需要的。好了，放松一点，让我们从现在起一步步领略API的好处吧。　　前言　　1.API　　API全称为Application Programming Interface，直译的话可叫它“应用程序接口”。从意义上来说，API是一个操作系统或某个程序本身提供给其他程序使用的函数。在Windows操作系统中，有成千个Windows的函数提供给应用程序使用，本文所说的API，就是指这些函数。　　2.VB与API　　之所以写这篇文章（而不写VC或其他语言），是因为VB对API的支持不是直接的，而且是不完全的; 在使用上，Windows的API编写时是假设调用者是C或C++语言，因此VB调用API不是很方便，也经常有不必要的错误或不明白如何使用的情况出现。本文的对象主要还是对API没有很深研究的读者，如果你不想了解太多细节，你可以把一个合适的函数用法搬过去，或者你完全不知道API，或咧恢郎偈孕矶嗪共磺宄绾问褂茫蛘吣阆Ｍ梢源颖疚难У礁嗍褂肁PI的技巧甚至VB的技巧（但愿我可以让你学到），我想你都应该看这篇文章。但还是有个大前提，你必须是已经会使用VB的读者，因为以后讲到的内容不会有一个完整工程从头到尾教你做，有可能是一段简短的声明与调用代码，也可能是几个函数的组合，如果必要的话，也会讲述相关内容的VB技巧，但一定不会有完整的实例示范。　　3.本文原则和约定　　由于API中有的用法简单有的复杂，有的可单独使用有的却不行，加上各个API的主要用途不同，很难判断先说哪个再说哪个可以让人更容易理解，因此本文尽量从比较常用的说起，从可以对程序产生较大作用的说起。为了能让多数人理解，如果需要涉及到其他方面的知识，也将尽量讲述，让读者可以学到使用API的知识，并能够利用本文中的知识应付新的API。如果你对某个API有什么疑问，欢迎来信（[email protected]），但由于时间有限，不能对来信一一回复，如果有需要，将会在文中讲述。基础知识　　在讲API之前，让我先讲解一些与API相关的VB基础知识，后文如有涉及将不再详述。此处未提及的，将在本文中第一次接触时再做解释。　　1.自定义类型　　VB中可以使用Type关键字将已有的数据类型进行组合，成为一个新的类型，该类型就称为用户自定义类型。如：Type NewTypesName As StringlNumber As LongEnd Type　　定义了一个名为NewType的自定义类型。以后可以用Dim MyType As NewType来定义一个NewType类型的变量。　　sName As String类型的变量有两种，一种是变长，即运行时的字符串长度是可变的，另一种是定长，运行时字符串的长度是固定的。平常我们定义一个字符串变量: Dim strA As String 即定义了一个变长的字符串，但在使用API时经常要用到定长的字符串，应该这样定义: Dim strB As String * 30，即定义了一个可容纳30个字节字符的变量。　　2.声明　　VB中使用API之前，需要先对API进行声明，声明的方法是使用Declare关键字，如:Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

SendMessage函数巧应用 1、设置树型列表控件的背景颜色首先做如下的定义：Private Declare Function SendMessage Lib "user32" Alias "Send MessageA" (ByVal hwnd As Long,ByVal wMsg As Long, ByVal wParam As Long,ByVal lParam As Long) As LongConst TV－FIRST = ＆H1100Const TVM－SETBKCOLOR = TV_FIRST ＋ 29然后再作如下调用：Call SendMessage(TreeView1.hwnd, TVM－SETBKCOLOR, 0, RGB(255, 0, 0))上面的SendMessage调用将TreeView1的背景颜色设置为红色。大家可能注意到了。在上面的Sendmessage函数定义中，我们将lParam定义为 ByVal lParam As Long，而不是象前面的那些范例那样定义为Any或者String类型，关于这个问题，我会在最后的一章中做介绍。2、设置树型列表控件标题行高度利用TVM_SETITEMHEIGHT消息可以设定控件的标题行的高度，该消息的定义及调用方法如下：定义：Const TV_FIRST = ＆H1100Const TVM－SETITEMHEIGHT = TV_FIRST ＋ 27Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long,ByVal wMsg As Long,ByVal wParam As Long,lParam As Any) As Long调用：CallSendMessage(TreeView1.hwnd, TVM－SETITEMHEIGHT, 60, 0)上面的代码将TreeView1的标题行高度设置到60像素高3、为树型列表控件中不同的标题行设置不同的提示在第一期的ListBox控件介绍中，我向大家介绍了如何为列表中的每一个标题行设置不同的提示(ToolTips)，在这里为要向大家介绍如何为树型列表控件中的每一个标题设置不同的提示。同ListBox控件不通，树型列表控件中并没有根据光标位置获得标题行索引的消息，我们需要另外想办法。在TVM类消息中有一个TVM_HITTEST消息，发送该消息可以检测控件表面上的某一点，如果该点位于一个标题上，则返回该标题的句柄。而利用TVM_GETITEM消息，则可以根据标题句柄返回该标题行的文本。所以结合利用这两个消息可以获取光标所在标题行的标题文本。具体的范例代码如下：Option Explicit Private Type TPointx As Longy As LongEnd TypePrivate Type TVHITTESTINFOpt As TPointflags As LonghItem As LongEnd TypePrivate Type TVITEMmask As LongHTreeItem As Longstate As LongstateMask As LongpszText As LongcchTextMax As LongiImage As LongiSelectedImage As LongcChildren As LonglParam As LongEnd TypeConst TV－FIRST = ＆H1100Const TVM_HITTEST = TV－FIRST ＋ 17Const TVM_GETITEM = TV－FIRST ＋ 12Const TVHT－ONITEMLABEL = ＆H4Const TVIF－TEXT = ＆H1Const GMEM－FIXED = ＆H0Private Declare Function Send MessageRef Lib"user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,ByVal wParam As Long,lParam As Any) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As String，ByVal Source As Long,ByVal Length As Long)Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPrivate Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As LongDim hItemPrv As LongPrivate Sub Form_Load()Dim ndX As Node`加入若干ItemSet ndX = TreeView1.Nodes.Add(, , "R", "Root")Set ndX = TreeView1.Nodes.Add("R", tvwChild, "Key1", "Node1")Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey1", "SubNode1")Set ndX = TreeView1.Nodes.Add("SubKey1", tvwChild, "SubKeys1", "SubNode1")Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey2", "SubNode2")Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey3", "SubNode3")Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey4", "SubNode4")End SubPrivate Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Dim ptA As TPointDim tf As TVHITTESTINFODim tv As TVITEMDim hStr As LongDim hItem As LongDim astr As String ＊ 1024Dim bstrOn Error GoTo errLab`获得当前光标所在的位置坐标ptA.x = Int(x / Screen.TwipsPerPixelX)ptA.y = Int(y / Screen.TwipsPerPixelY)tf.pt = ptAtf.flags = TVHT_ONITEMLABEL`获得光标所在的Item的句柄hItem = SendMessageRef(TreeView1.hwnd, TVM_HITTEST, 0, tf)`如果未获得句柄或者同上一次是同一个Item的句柄则退出If ((hItem <= 0) Or (hItem = hItemPrv)) Then Exit SubhItemPrv = hItem`分配一定的内存空间用以存储Item的标题hStr = GlobalAlloc(GMEM－FIXED, 1024)If hStr > 0 Thentv.mask = TVIF_TEXT `获取标题文本tv.HTreeItem = hItem`Item句柄tv.pszText = hStrtv.cchTextMax = 1023`发送TVM_GETITEM获得标题文本CallSendMessageRef(TreeView1.hwnd, TVM－GETITEM, 0, tv)`将标题文本拷贝到字符串astr中CopyMemory astr, hStr, 1024bstr = Left＄(astr, (InStr(astr, Chr(0)) － 1))TreeView1.ToolTipText = bstr`释放分配的内存空间GlobalFree hStrEnd IfExit SuberrLab:Resume NextEnd Sub运行上面的程序，当光标在TreeView1上面移动时，TreeView1的ToolTips就会根据光标所在的不同标题行而变动。以上程序在Win98、Win2000，VB6下运行通过

利用Api函数计算Windows从启动后所运行的总时间 Private Declare Function GetTickCount Lib "kernel32" () As LongPrivate Sub Timer1_Timer()Dim hour As IntegerDim minute As IntegerDim second As Integerhour = GetTickCount \ 1000 \ 60 \ 60Label1.Caption = Str(hour) + "小时"minute = (GetTickCount - hour * 60 * 60 * 1000) \ 1000 \ 60Label2.Caption = Str(minute) + "分钟"second = (GetTickCount - Val(Label1.Caption) * 60 * 60 * 1000 - Val(Label2.Caption) * 60 * 1000) \ 1000Label3.Caption = Str(second) + "秒钟"End Sub

VBA命令例为设置密码窗口 (1) If Application.InputBox("请输入密码：") = 1234 Then [A1] = 1 '密码正确时执行 Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码 End If 本示例为设置密码窗口 (1) X = MsgBox("是否真的要结帐？", vbYesNo) If X = vbYes Then Close 本示例为设置工作表密码 ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码 ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码 '本示例关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容。 For Each w In Workbooks If w.Name ThisWorkbook.Name Then w.Close SaveChanges:=True End If Next w '每次打开工作簿时，本示例都最大化 Microsoft Excel 窗口。 Application.WindowState = xlMaximized '本示例显示活动工作表的名称。 MsgBox "The name of the active sheet is " & ActiveSheet.Name '本示例保存当前活动工作簿的副本。 ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS" '下述过程激活工作簿中的第四张工作表。 Sheets(4).Activate '下述过程激活工作簿中的第1张工作表。 Worksheets(1).Activate '本示例通过将 Saved 属性设为 True 来关闭包含本段代码的工作簿，并放弃对该工作簿的任何更改。 ThisWorkbook.Saved = True ThisWorkbook.Close '本示例对自动重新计算功能进行设置，使 Microsoft Excel 不对第一张工作表自动进行重新计算。 Worksheets(1).EnableCalculation = False '下述过程打开 C 盘上名为 MyFolder 的文件夹中的 MyBook.xls 工作簿。 Workbooks.Open ("C:\MyFolder\MyBook.xls") '本示例显示活动工作簿中工作表 sheet1 上单元格 A1 中的值。 MsgBox Worksheets("Sheet1").Range("A1").Value 本示例显示活动工作簿中每个工作表的名称 For Each ws In Worksheets MsgBox ws.Name Next ws 本示例向活动工作簿添加新工作表 , 并设置该工作表的名称? Set NewSheet = Worksheets.Add NewSheet.Name = "current Budget" 本示例将新建的工作表移到工作簿的末尾 'Private Sub Workbook_NewSheet(ByVal Sh As Object) Sh.Move After:=Sheets(Sheets.Count) End Sub 本示例将新建工作表移到工作簿的末尾 'Private Sub App_WorkbookNewSheet(ByVal Wb As Workbook, _ ByVal Sh As Object) Sh.Move After:=Wb.Sheets(Wb.Sheets.Count) End Sub 本示例新建一张工作表，然后在第一列中列出活动工作簿中的所有工作表的名称。 Set NewSheet = Sheets.Add(Type:=xlWorksheet) For i = 1 To Sheets.Count NewSheet.Cells(i, 1).Value = Sheets(i).Name Next i 本示例将第十行移到窗口的最上面? Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 10 当计算工作簿中的任何工作表时，本示例对第一张工作表的 A1:A100 区域进行排序。 'Private Sub Workbook_SheetCalculate(ByVal Sh As Object) With Worksheets(1) .Range("a1:a100").Sort Key1:=.Range("a1") End With End Sub 本示例显示工作表 Sheet1 的打印预览。 Worksheets("Sheet1").PrintPreview 本示例保存当前活动工作簿? ActiveWorkbook.Save 本示例保存所有打开的工作簿，然后关闭 Microsoft Excel。 For Each w In Application.Workbooks w.Save Next w Application.Quit 下例在活动工作簿的第一张工作表前面添加两张新的工作表? Worksheets.Add Count:=2, Before:=Sheets(1) 本示例设置 15 秒后运行 my_Procedure 过程，从现在开始计时。 Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure"

在 XP/2K 任务管理器的进程列表中隐藏当前进程 Option Explicit'-----------------------------------------------------'模块名称：modHideProcess.bas''模块功能：在 XP/2K 任务管理器的进程列表中隐藏当前进程''使用方法：直接调用 HideCurrentProcess()''''-----------------------------------------------------Private Const STATUS_INFO_LENGTH_MISMATCH = &HC0000004Private Const STATUS_ACCESS_DENIED = &HC0000022Private Const STATUS_INVALID_HANDLE = &HC0000008Private Const ERROR_SUCCESS = 0&Private Const SECTION_MAP_WRITE = &H2Private Const SECTION_MAP_READ = &H4Private Const READ_CONTROL = &H20000Private Const WRITE_DAC = &H40000Private Const NO_INHERITANCE = 0Private Const DACL_SECURITY_INFORMATION = &H4Private Type IO_STATUS_BLOCKStatus As LongInformation As LongEnd TypePrivate Type UNICODE_STRINGLength As IntegerMaximumLength As IntegerBuffer As LongEnd TypePrivate Const OBJ_INHERIT = &H2Private Const OBJ_PERMANENT = &H10Private Const OBJ_EXCLUSIVE = &H20Private Const OBJ_CASE_INSENSITIVE = &H40Private Const OBJ_OPENIF = &H80Private Const OBJ_OPENLINK = &H100Private Const OBJ_KERNEL_HANDLE = &H200Private Const OBJ_VALID_ATTRIBUTES = &H3F2Private Type OBJECT_ATTRIBUTESLength As LongRootDirectory As LongObjectName As LongAttributes As LongSecurityDeor As LongSecurityQualityOfService As LongEnd TypePrivate Type ACLAclRevision As ByteSbz1 As ByteAclSize As IntegerAceCount As IntegerSbz2 As IntegerEnd TypePrivate Enum ACCESS_MODENOT_USED_ACCESSGRANT_ACCESSSET_ACCESSDENY_ACCESSREVOKE_ACCESSSET_AUDIT_SUCCESSSET_AUDIT_FAILUREEnd EnumPrivate Enum MULTIPLE_TRUSTEE_OPERATIONNO_MULTIPLE_TRUSTEETRUSTEE_IS_IMPERSONATEEnd EnumPrivate Enum TRUSTEE_FORMTRUSTEE_IS_SIDTRUSTEE_IS_NAMEEnd EnumPrivate Enum TRUSTEE_TYPETRUSTEE_IS_UNKNOWNTRUSTEE_IS_USERTRUSTEE_IS_GROUPEnd EnumPrivate Type TRUSTEEpMultipleTrustee As LongMultipleTrusteeOperation As MULTIPLE_TRUSTEE_OPERATIONTrusteeForm As TRUSTEE_FORMTrusteeType As TRUSTEE_TYPEptstrName As StringEnd TypePrivate Type EXPLICIT_ACCESSgrfAccessPermissions As LonggrfAccessMode As ACCESS_MODEgrfInheritance As LongTRUSTEE As TRUSTEEEnd TypePrivate Type AceArrayList() As EXPLICIT_ACCESSEnd TypePrivate Enum SE_OBJECT_TYPESE_UNKNOWN_OBJECT_TYPE = 0SE_FILE_OBJECTSE_SERVICESE_PRINTERSE_REGISTRY_KEYSE_LMSHARESE_KERNEL_OBJECTSE_WINDOW_OBJECTSE_DS_OBJECTSE_DS_OBJECT_ALLSE_PROVIDER_DEFINED_OBJECTSE_WMIGUID_OBJECTEnd EnumPrivate Declare Function SetSecurityInfo Lib "advapi32.dll" (ByVal Handle As Long, ByVal ObjectType As SE_OBJECT_TYPE, ByVal SecurityInfo As Long, ppsidOwner As Long, ppsidGroup As Long, ppDacl As Any, ppSacl As Any) As LongPrivate Declare Function GetSecurityInfo Lib "advapi32.dll" (ByVal Handle As Long, ByVal ObjectType As SE_OBJECT_TYPE, ByVal SecurityInfo As Long, ppsidOwner As Long, ppsidGroup As Long, ppDacl As Any, ppSacl As Any, ppSecurityDeor As Long) As LongPrivate Declare Function SetEntriesInAcl Lib "advapi32.dll" Alias "SetEntriesInAclA" (ByVal cCountOfExplicitEntries As Long, pListOfExplicitEntries As EXPLICIT_ACCESS, ByVal OldAcl As Long, NewAcl As Long) As Long

欢迎访问VB技术交流吧“VB编程乐园”有兴趣的去踩一下，会有收获的 http://post.baidu.com/f?kw=vb%B1%E0%B3%CC%C0%D6%D4%B0

新建有系统和隐藏属性的文件这个用SetAttr实现. 格式如下 SetAttr pathname, attributes 比如SetAttr "C:\test.txt",vbHidden '隐藏 SetAttr "C:\test.txt",vbSystem '系统文件另外也可以用GetAttr pathname 来获取文件属性

VB编程乐园吧诚心寻找吧主一名，有意思的去吧里留言本人由于工作原因，不能经常管理吧里事务，现诚心寻找一名管理吧务的吧主，此吧为VB技术交流吧，不接受和保存一切反对国家，反对人类，反对人民的一切言论，谢绝广告，只提供VB技术交流，对吧主要求：熟悉VB，能帮助吧里的朋友们。让我们一起努力把吧做好！！！

自动适应窗口 Public FormOldWidth, FormOldHeight Private Sub Form_Load() FormOldWidth = Me.ScaleWidth FormOldHeight = Me.ScaleHeight Dim Obj As Control On Error Resume Next For Each Obj In Me Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " " Next Obj End Sub Private Sub Form_Resize() Dim pos(4) ScaleX1 = Me.ScaleWidth / FormOldWidth ScaleY1 = Me.ScaleHeight / FormOldHeight On Error Resume Next For Each Obj In Me StartPos = 1 For i = 0 To 4 TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare) If TempPos > 0 Then pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos) StartPos = TempPos + 1 Else: pos(i) = 0 End If Obj.Move pos(0) * ScaleX1, pos(1) * ScaleY1, pos(2) * ScaleX1, pos(3) * ScaleY1 Next i Next Obj End Sub

获知操作系统安装在哪个盘 'Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Sub Form_Load() Dim sSave$, winsys$, Ret&, jj& sSave = Space(255) Ret = GetSystemDirectory(sSave, 255) jj = Len(Trim(sSave)) winsys = Trim(Mid(sSave, 1, jj - 1)) MsgBox "系统盘在 " & Left(winsys, 1) & " 盘" End Sub

自定义VB系统控件的文章 Visual Basic 是一种RAD工具,之所以说它是RAD工具就是因为很多底层初级的东西已经被IDE封装好,我们只要直接用就好了,因此我们可以用VB来进行快速的应用开发。举个例子：如果用代码创建一个正常工作的窗体至少需要调用如下几个API：RegisterClass或RegisterClassEx：该函数为随后在调用Createwindow函数和CreatewindowEx函数中使用的窗口注册一个窗口类UnregisterClass：删除一个窗口类,清空该类所需的内存DefWindowProc：该函数调用缺省的窗口过程来为应用程序没有处理的任何窗口消息提供缺省的处理。该函数确保每一个消息得到处理。调用DefWindowProc函数时使用窗口过程接收的相同参数GetMessage：该函数从调用线程的消息队列里取得一个消息并将其放于指定的结构TranslateMessage：该函数将虚拟键消息转换为字符消息DispatchMessage：该函数调度一个消息给窗口程序,通常调度从GetMessage取得的消息ShowWindow：用于设置窗口的状态,其中包括窗口的隐藏、显示、最小化、最大化、激活等UpdateWindow：立即更新窗口内需要更新的任何部分CreateWindowEx：该函数创建一个具有扩展风格的重叠式窗口、弹出式窗口或子窗口,其他与CreateWindow函数相同CallWindowProc：该函数CallWindowProc将消息信息传送给指定的窗口过程。SetWindowLong,GetWindowLong：用于获取或设置与窗口有关的信息PostQuitMessage：将一条消息投递到指定窗口的消息队列DestroyWindow：清除指定的窗口以及下属所有子窗口与包容窗口.进行几个繁琐的操作才能创建一个窗体。然后还有进行各种消息处理等等,但是有了VB这种RAD工具所有这些我们都可以不用关心,因为VB已经为我们封装好了。我们所要做的且关心的就是怎么设计我们自己的应用。做个比喻就像我们已经有了房子只需要按照自己的需要进行装修即可,但是非RAD工具是从楼房的地基(地址有操作系统提供）开始。但是,凡事没有绝对的优点也没有绝对的缺点。站在不同的角度看待同一个事物却会有不同的结果。如果我想在VB中在反过来深入底层将是很麻烦的事。按照自己的想法盖房子和将已经建好的楼房进行改建更麻烦(我这里用的是麻烦,并不是困难）,它的难点就是如何找到切入点。但是如果能够灵活运用系统API,能够找到切入点,将会起到事半功倍的效果。下面用实际的例子进行一些演示说明,由于本人技术及篇幅有限,不事宜做复杂的说明。那些做为专题讨论,写这篇主要目的是起到抛砖引玉的作用。严格说来操作系统只知道窗口控件(WinControl）的存在,我这里说的窗口控件可以这么理解就是在VB中具有hWnd(窗口句柄）的控件。他们都靠系统的消息驱动,因为我在这篇文章主要侧重点是利用API来发掘VB,因此涉及的对象基本都是指窗口控件,非窗口控件的创建、更新、销毁又它的父窗口控件来负责。使用VC＋＋编程的人一定会熟悉很多窗体控件风格常量,然后按照自己的需要创建窗体控件样式,而我们在VB中,这些统统被IDE包装起来的,我和根本看不到,但是利用API我们可以重新定义窗体控件的样式,下面就用实际例子来演示一下：(这里我没有列出详细的API和常量声明,因为我主要想体现的是方法和思路）任何一个窗体控件,我们都可以给它加上ControlBox(所谓ControlBox,就是窗体的图标＋最小化＋最大化＋关闭按钮）Option ExplicitPrivate 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 Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _

提高代码的运行速度第一部分：编码技术。下面的这些方法(到现在为止共27种）可以帮助你提高代码的运行速度：　　1. 使用整数(Integer）和长整数(Long）　　提高代码运行速度最简单的方法莫过于使用正确的数据类型了。也许你不相信,但是正确地选择数据类型可以大幅度提升代码的性能。在大多数情况下,程序员可以将Single,Double和Currency类型的变量替换为Integer或Long类型的变量,因为VB处理Integer和Long的能力远远高于处理其它几种数据类型。下面是排序：Long 最快 Integer . Byte . Single . Double . Currency 最慢　　在大多数情况下,程序员选择使用Single或Double的原因是因为它们能够保存小数。但是小数也可以保存在Integer类型的变量中。例如程序中约定有三位小数,那么只需要将保存在Integer变量中的数值除以1000就可以得到结果。根据我的经验,使用Integer和Long替代Single,Double和Currency后,代码的运行速度可以提高将近10倍。　　2. 避免使用变体　　对于一个VB程序员来说,这是再明显不过的事情了。变体类型的变量需要16个字节的空间来保存数据,而一个整数(Integer）只需要2个字节。通常使用变体类型的目的是为了减少设计的工作量和代码量,也有的程序员图个省事而使用它。但是如果一个软件经过了严格设计和按照规范编码的话,完全可以避免使用变体类型。　　在这里顺带提一句,对于Object对象也存在同样的问题。请看下面的代码：Dim FSO Set FSO = New Scripting.FileSystemObject 　　或Dim FSO as objectSet FSO = New Scripting.FileSystemObject 　　上面的代码由于在申明的时候没有指定数据类型,在赋值时将浪费内存和CPU时间。正确的代码应该象下面这样：Dim FSO as New FileSystemObject 　　3. 尽量避免使用属性　　在平时的代码中,最常见的比较低效的代码就是在可以使用变量的情况下,反复使用属性(Property）,尤其是在循环中。要知道存取变量的速度是存取属性的速度的20倍左右。下面这段代码是很多程序员在程序中会使用到的：Dim intCon as IntegerFor intCon = 0 to Ubound(SomVar())Text1.Text = Text1.Text & vbcrlf & SomeVar(intCon)Next intCon 　　下面这段代码的执行速度是上面代码的20倍。 Dim intCon as IntegerDim sOutput as StringFor intCon = 0 to Ubound(SomeVar())sOutput = sOutput & vbCrlf &SomeVar(intCon)NextText1.Text = sOutput 同样地,像这样的代码 . . . Do Until EOF(F) Line Input #F, nextLine Text1.Text = Text1.Text + nextLine Loop . . . 比下面的代码慢得多： Do Until EOF(F) Line Input #F, nextLine bufferVar = bufferVar + nextLine Loop Text1.Text = bufferVar 然而,下面的代码完成了相同的功能,而且还要快： Text1.Text = Input(F, LOF(F)) 如上述,几种方法都实现了同样的任务；同时,最好的算法也是最优的。　　4. 尽量使用数组,避免使用集合　　除非你必须使用集合(Collection）,否则你应该尽量使用数组。据测试,数组的存取速度可以达到集合的100倍。这个数字听起来有点骇人听闻,但是如果你考虑到集合是一个对象,你就会明白为什么差异会这么大。　　5. 展开小的循环体　　在编码的时候,有可能遇到这种情况：一个循环体只会循环2到3次,而且循环体由几行代码组成。在这种情况下,你可以把循环展开。原因是循环会占用额外的CPU时间。但是如果循环比较复杂,你就没有必要这样做了。　　6. 避免使用很短的函数　　和使用小的循环体相同,调用只有几行代码的函数也是不经济的--调用函数所花费的时间或许比执行函数中的代码需要更长的时间。在这种情况下,你可以把函数中的代码拷贝到原来调用函数的地方。