VB常用代码总结（一）【转】

 

VB常用代码总结（一）【转】

 

移动无标题栏的窗体(borderstyle=none) dim mouseX as integer dim mouseY as integer dim moveX as integer dim moveY as integer dim down as boolean form_mousedown: 'mousedown事件 down=true mouseX=x mouseY=y form_mouseup: 'mouseup事件 down=false form_mousemove if down=true then    moveX=me.left-mouseX+X    moveY=me.top-mouseY+Y    me.move moveX,moveY end if *********************************************************************** 闪烁控件 比如要闪烁一个label（标签） 添加一个时钟控件 间隔请根据实际需要设置 enabled属性设为true 代码为：label1.visible=not label1.visible ********************************************************************** 禁止使用 Alt+F4 关闭窗口 Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long Private Const MF_BYPOSITION = &H400& Private Sub Form_Load() Dim hwndMenu As Long Dim c As Long hwndMenu = GetSystemMenu(Me.hwnd, 0) c = GetMenuItemCount(hwndMenu) DeleteMenu hwndMenu, c - 1, MF_BYPOSITION c = GetMenuItemCount(hwndMenu) DeleteMenu hwndMenu, c - 1, MF_BYPOSITION End Sub *********************************************************************** 启动控制面板大全 '打开控制面板 Call Shell("rundll32.exe shell32.dll,Control_RunDLL", 9) '辅助选项 属性-键盘 Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1", 9) '辅助选项 属性-声音 Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2", 9) '辅助选项 属性-显示 Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3", 9) '辅助选项 属性-鼠标 Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4", 9) '辅助选项 属性-常规 Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5", 9) '添加/删除程序 属性-安装/卸载 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,1", 9) '添加/删除程序 属性-Windows安装程序 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,2", 9) '添加/删除程序 属性-启动盘 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Appwiz.cpl,,3", 9) '显示 属性-背景 Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 9) '显示 属性-屏幕保护程序 Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", 9) '显示 属性-外观 Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", 9) '显示 属性-设置 Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", 9) 'Internet 属性-常规 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,0", 9) 'Internet 属性-安全 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,1", 9) 'Internet 属性-内容 Call Shell("rundll32.exe shell32.dll,Control_RunDLL Inetcpl.cpl,,2", 9) 'Internet 属性-连接 Call Shell("rundll32.exe shell32.dll,Control_RunDLL I ***************************************************************** 怎样关闭一个程序 你可以使用API函数FindWindow和PostMessage来寻找一个窗口并且关闭它。下面的范例演示如何关闭一个标题为"Calculator"的窗口。 Dim winHwnd As Long Dim RetVal As Long winHwnd = FindWindow(vbNullString, "Calculator") Debug.Print winHwnd If winHwnd <> 0 Then RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&) If RetVal = 0 Then MsgBox "Error posting message." End If Else MsgBox "The Calculator is not open." End If For this code to work, you must have declared the API functions in a module in your project. You must put the following in the declarations section of the module. Declare Function FindWindow Lib "user32" Alias _ "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Declare Function PostMessage Lib "user32" Alias _ "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Public Const WM_CLOSE = &H10 ***************************************************************** 如何使Form的背景图随Form大小改变 单纯显示图形用Image即可,而且用Image也正好可解决你的问题 设定Image的Stretch=true 在加入以下的code Private Sub Form_Resize() Image1.Move 0, 0, ScaleWidth, ScaleHeight End Sub 或者使用以下的方式来做也可以 Private Sub Form_Paint() Me.PaintPicture Me.Picture, 0, 0, ScaleWidth, ScaleHeight End Sub ************************************************************************* 软件的注册 可用注册表简单地保存已用的天数或次数 '次数限制（如３０次）如下： Private Sub Form_Load() Dim RemainDay As Long RemainDay = GetSetting("MyApp", "set", "times", 0) If RemainDay = 30 Then    MsgBox "试用次数已满，请注册"    Unload Me End If MsgBox "现在剩下：" & 30 - RemainDay & "试用次数，好好珍惜！" RemainDay = RemainDay + 1 SaveSetting "MyApp", "set", "times", RemainDay End Sub '时间限制的（如３０天） Private Sub Form_Load() Dim RemainDay As Long RemainDay = GetSetting("MyApp", "set", "day", 0) If RemainDay = 30 Then     MsgBox "试用期已过，请注册"     Unload Me End If MsgBox "现在剩下：" & 30 - RemainDay & "试用天数，好好珍惜！" if day(now)-remainday>0 then RemainDay = RemainDay + 1 SaveSetting "MyApp", "set", "times", RemainDay End Sub ***************************************************************** MMControl控件全屏播放 Option Explicit Private Declare Function mciSendString Lib "winmm.dll" _         Alias "mciSendStringA" (ByVal lpstrCommand As _         String, ByVal lpstrReturnString As Any, ByVal _         uReturnLength As Long, ByVal hwndCallback As _         Long) As Long Private Declare Function mciSendCommand Lib "winmm.dll" _         Alias "mciSendCommandA" (ByVal wDeviceID As Long, _         ByVal uMessage As Long, ByVal dwParam1 As Long, _         dwParam2 As MCI_OVLY_RECT_PARMS) As Long Private Declare Function GetShortPathName Lib "kernel32" _         Alias "GetShortPathNameA" (ByVal lpszLongPath As _         String, ByVal lpszShortPath As String, ByVal _         cchBuffer As Long) As Long         Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type MCI_OVLY_RECT_PARMS dwCallback As Long rc As RECT End Type Const MCI_OVLY_WHERE_SOURCE = &H20000 Const MCI_OVLY_WHERE_DESTINATION = &H40000 Const MCI_WHERE = &H843 Dim Play As Boolean Private Sub Form_Load() MMControl1.Wait = True MMControl1.UpdateInterval = 50 MMControl1.hWndDisplay = Picture1.hWnd Picture1.ScaleMode = 3 Timer1.Interval = 50 End Sub Private Sub Form_Unload(Cancel As Integer) MMControl1.Command = "stop" MMControl1.Command = "close" End Sub Private Sub Command1_Click() MMControl1.Command = "stop" MMControl1.Command = "close" Play = False CommonDialog1.Filter = ("VB-Dateien (*.avi)|*.avi;") CommonDialog1.InitDir = App.Path CommonDialog1.ShowOpen If CommonDialog1.filename <> "" Then     MMControl1.DeviceType = "avivideo"     MMControl1.filename = CommonDialog1.filename     MMControl1.Command = "open"     MMControl1.Notify = True     Label4.Caption = MMControl1.Length     If Check2.Value = vbChecked And Option2 Then       Call AdaptPicture     End If         If Option3.Value Then Call Option3_Click     Me.Caption = CommonDialog1.filename End If End Sub Private Sub Command2_Click() If Not Option3.Value Then     If Play = False And MMControl1.filename <> "" Then       MMControl1.Command = "play"       Play = True     End If Else     Call Option3_Click End If End Sub Private Sub Command3_Click() Play = False MMControl1.Command = "stop" End Sub Private Sub Command4_Click() MMControl1.Command = "pause" End Sub Private Sub MMControl1_Done(NotifyCode As Integer) If Play And Check1.Value = vbChecked Then     Play = False     MMControl1.Command = "stop"     MMControl1.Command = "prev"     MMControl1.Command = "play"     Play = True End If End Sub Private Sub MMControl1_StatusUpdate() Label2.Caption = MMControl1.Position End Sub Private Sub Option1_Click() Check1.Enabled = True Check2.Enabled = False MMControl1.hWndDisplay = 0 End Sub Private Sub Option2_Click() Check1.Enabled = True Check2.Enabled = True MMControl1.hWndDisplay = Picture1.hWnd End Sub Private Sub Option3_Click()‘－－－－－－－－－－－注意这里 Dim R&, AA$     Check1.Enabled = False     Check2.Enabled = False     MMControl1.Command = "stop"     Play = False         AA = Space$(255)     R = GetShortPathName(CommonDialog1.filename, AA, Len(AA))     AA = Mid$(AA, 1, R)     R = mciSendString("play " & AA & " fullscreen ", 0&, 0, 0&) End Sub Private Sub Check2_Click() If Check2.Value = vbChecked And MMControl1.filename <> "" Then     Call AdaptPicture End If End Sub Private Sub Timer1_Timer() Dim x%, AA$     x = MMControl1.Mode     Select Case x       Case 524: AA = "NotOpen"       Case 525: AA = "Stop"       Case 526: AA = "Play"       Case 527: AA = "Record"       Case 528: AA = "Seek"       Case 529: AA = "Pause"       Case 530: AA = "Ready"     End Select     Label6.Caption = AA End Sub Private Sub AdaptPicture() Dim Result&, Par As MCI_OVLY_RECT_PARMS         Par.dwCallback = MMControl1.hWnd     Result = mciSendCommand(MMControl1.DeviceID, _              MCI_WHERE, MCI_OVLY_WHERE_SOURCE, Par)     If Result <> 0 Then       MsgBox ("Fehler")     Else       Picture1.Width = (Par.rc.Right - Par.rc.Left) * 15 + 4 * 15       Picture1.Height = (Par.rc.Bottom - Par.rc.Top) * 15 + 4 * 15     End If End Sub ****************************************************************** 通用对话框专辑（全） 使用API调用Winodws各种通用对话框(Common Diaglog)的方法（一） 1.文件属性对话框 Type SHELLEXECUTEINFO cbSize As Long fMask As Long hwnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long '可选参数 lpClass As String '可选参数 hkeyClass As Long '可选参数 dwHotKey As Long '可选参数 hIcon As Long '可选参数 hProcess As Long '可选参数 End Type Const SEE_MASK_INVOKEIDLIST = &HC Const SEE_MASK_NOCLOSEPROCESS = &H40 Const SEE_MASK_FLAG_NO_UI = &H400 Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" _ (SEI As SHELLEXECUTEINFO) As Long Public Function ShowProperties(filename As String, OwnerhWnd As Long) As Long '打开指定文件的属性对话框,如果返回值<=32则出错 Dim SEI As SHELLEXECUTEINFO Dim r As Long With SEI .cbSize = Len(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI .hwnd = OwnerhWnd .lpVerb = "properties" .lpFile = filename .lpParameters = vbNullChar .lpDirectory = vbNullChar .nShow = 0 .hInstApp = 0 .lpIDList = 0 End With r = ShellExecuteEX(SEI) ShowProperties = SEI.hInstApp End Function 新建一个工程,添加一个按钮和名为Text1的文本框 把以下代码置入CommandbButton_Click 中 Dim r As Long Dim fname As String '从Text1 中获取文件名及路径 fname = (Text1) r = ShowProperties(fname, Me.hwnd) If r <= 32 Then MsgBox "Error" 2.使用Win95的关于对话框 Private Declare Function ShellAbout Lib "shell32.dll" _ Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _ ByVal szOtherStuff As String, ByVal hIcon As Long) As Long 示例: Dim x As Long x = shellabout (Form1.hwnd, "Visual Basic 6.0", _ "Alp Studio MouseTracker Ver 1.0", Form1.icon) 2.调用"捕获打印机端口"对话框 Private Declare Function WNetConnectionDialog Lib "mpr.dll" _ (ByVal hwnd As Long, ByVal dwType As Long) As Long 示例: Dim x As Long x = WNetConnectionDialog(Me.hwnd, 2) 3.调用颜色对话框 Private Type ChooseColor lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long 将以下代码置入某一事件中: Dim cc As ChooseColor Dim CustColor(16) As Long cc.lStructSize = Len(cc) cc.hwndOwner = Form1.hWnd cc.hInstance = App.hInstance cc.flags = 0 cc.lpCustColors = String$(16 * 4, 0) Dim a Dim x Dim c1 Dim c2 Dim c3 Dim c4 a = ChooseColor(cc) Cls If (a) Then MsgBox "Color chosen:" & Str$(cc.rgbResult) For x = 1 To Len(cc.lpCustColors) Step 4 c1 = Asc(Mid$(cc.lpCustColors, x, 1)) c2 = Asc(Mid$(cc.lpCustColors, x + 1, 1)) c3 = Asc(Mid$(cc.lpCustColors, x + 2, 1)) c4 = Asc(Mid$(cc.lpCustColors, x + 3, 1)) CustColor(x / 4) = (c1) + (c2 * 256) + (c3 * 65536) + (c4 * 16777216) MsgBox "Custom Color " & Int(x / 4) & " = " & CustColor(x / 4) Next x Else MsgBox "Cancel was pressed" End If 4.调用复制磁盘对话框 Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 示例: 向窗体中添加一个名为Drive1的DriveListBox,将以下代码置入某一事件中 Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg& DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - 65) DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " _ & DriveNumber & "," & DriveNumber, 1) 'Notice space after Else ' Just in case 'DiskCopyRunDll RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _ "be diskcopied!", 64, "DiskCopy Example") End If 5.调用格式化软盘对话框 Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 参数设置: fmtID- 3.5" 5.25" ------------------------- 0 1.44M 1.2M 1 1.44M 1.2M 2 1.44M 1.2M 3 1.44M 360K 4 1.44M 1.2M 5 720K 1.2M 6 1.44M 1.2M 7 1.44M 1.2M 8 1.44M 1.2M 9 1.44M 1.2M 选项 0 快速 1 完全 2 只复制系统文件 3 只复制系统文件 4 快速 5 完全 6 只复制系统文件 7 只复制系统文件 8 快速 9 完全 示例:要求同上 Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg% DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0 DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Else RetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf & _ "drive! Format this drive?", 276, "SHFormatDrive Example") Select Case RetFromMsg Case 6 'Yes ' UnComment to do it... 'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Case 7 'No ' Do nothing End Select End If -----------------------------------------------------------------------------