【ACCESS精品源码栏目提醒】:网学会员为广大网友收集整理了,VB常用代码总结 - 软件工程,希望对大家有所帮助!
VB 常用代码总结原文出自 木蚂蚁 社区 ww w.m umayi .net本 贴地址: http:/ /bbs.m umayi .net/viewt hread.phpti d809605移动无标题栏的窗体borderstylenonedim mouseX as integerdim mouseY as integerdim moveX as integerdim moveY as integerdim down as booleanform_mousedown: mousedown 事件downtruemouseXxmouseYyform_mouseup: mouseup 事件downfalseform_mousemoveif downtrue then moveXme.left-mouseXX moveYme.top-mouseYY me.move moveXmoveYend if闪烁控件比如要闪烁一个 label(标签)添加一个时钟控件 间隔请根据实际需要设置 enabled 属性设为 true代码为:label1.visiblenot label1.visible禁止使用 AltF4 关闭窗口Private Declare Function DeleteMenu Lib quotuser32quot ByVal hMenu As LongByVal nPosition As Long ByVal wFlags As Long As LongPrivate Declare Function GetMenuItemCount Lib quotuser32quot ByVal hMenu AsLong As LongPrivate Const MF_BYPOSITION ampH400ampPrivate Sub Form_LoadDim hwndMenu As LongDim c As LonghwndMenu GetSystemMenuMe.hwnd 0c GetMenuItemCounthwndMenuDeleteMenu hwndMenu c - 1 MF_BYPOSITIONc GetMenuItemCounthwndMenuDeleteMenu hwndMenu c - 1 MF_BYPOSITIONEnd Sub启动控制面板大全打开控制面板Call Shellquotrundll32.exe shell32.dllControl_RunDLLquot 9辅助选项 属性-键盘Call Shellquotrundll32.exe shell32.dllControl_RunDLL
access.cpl1quot 9辅助选项 属性-声音Call Shellquotrundll32.exe shell32.dllControl_RunDLL
access.cpl2quot 9辅助选项 属性-显示Call Shellquotrundll32.exe shell32.dllControl_RunDLL
access.cpl3quot 9辅助选项 属性-鼠标Call Shellquotrundll32.exe shell32.dllControl_RunDLL
access.cpl4quot 9辅助选项 属性-常规Call Shellquotrundll32.exe shell32.dllControl_RunDLL
access.cpl5quot 9添加/删除程序 属性-安装/卸载Call Shellquotrundll32.exe shell32.dllControl_RunDLL Appwiz.cpl1quot 9添加/删除程序 属性-Windows 安装程序Call Shellquotrundll32.exe shell32.dllControl_RunDLL Appwiz.cpl2quot 9添加/删除程序 属性-启动盘Call Shellquotrundll32.exe shell32.dllControl_RunDLL Appwiz.cpl3quot 9显示 属性-背景Call Shellquotrundll32.exe shell32.dllControl_RunDLL desk.cpl0quot 9显示 属性-屏幕保护程序Call Shellquotrundll32.exe shell32.dllControl_RunDLL desk.cpl1quot 9显示 属性-外观Call Shellquotrundll32.exe shell32.dllControl_RunDLL desk.cpl2quot 9显示 属性-设置Call Shellquotrundll32.exe shell32.dllControl_RunDLL desk.cpl3quot 9Internet 属性-常规Call Shellquotrundll32.exe shell32.dllControl_RunDLL Inetcpl.cpl0quot 9Internet 属性-安全Call Shellquotrundll32.exe shell32.dllControl_RunDLL Inetcpl.cpl1quot 9Internet 属性-内容Call Shellquotrundll32.exe shell32.dllControl_RunDLL Inetcpl.cpl2quot 9Internet 属性-连接Call Shellquotrundll32.exe shell32.dllControl_RunDLL I怎样关闭一个程序你可以使用 API 函数 FindWindow 和 PostMessage 来寻找一个窗口并且关闭它。
下面的范例演示如何关闭一个标题为quotCalculatorquot的窗口。
Dim winHwnd As LongDim RetVal As LongwinHwnd FindWindowvbNullString quotCalculatorquotDebug.Print winHwndIf winHwnd ltgt 0 ThenRetVal PostMessagewinHwnd WM_CLOSE 0amp 0ampIf RetVal 0 ThenMsgBox quotError posting message.quotEnd IfElseMsgBox quotThe Calculator is not open.quotEnd IfFor this code to work you must have declared the API functions in a module inyour project. You must put the following in the declarations section of themodule.Declare Function FindWindow Lib quotuser32quot Alias _quotFindWindowAquot ByVal lpClassName As String _ByVal lpWindowName As String As LongDeclare Function PostMessage Lib quotuser32quot Alias _quotPostMessageAquot ByVal hwnd As Long ByVal wMsg As Long _ByVal wParam As Long lParam As Any As LongPublic Const WM_CLOSE ampH10如何使 Form 的背景图随 Form 大小改变单纯显示图形用 Image 即可而且用 Image 也正好可解决你的问题设定 Image 的 Stretchtrue在加入以下的 codePrivate Sub Form_ResizeImage1.Move 0 0 ScaleWidth ScaleHeightEnd Sub或者使用以下的方式来做也可以Private Sub Form_PaintMe.PaintPicture Me.Picture 0 0 ScaleWidth ScaleHeightEnd Sub软件的注册可用注册表简单地保存已用的天数或次数次数限制(如30次)如下:Private Sub Form_LoadDim RemainDay As LongRemainDay GetSettingquotMyAppquot quotsetquot quottimesquot 0If RemainDay 30 Then MsgBox quot试用次数已满,请注册quot Unload MeEnd IfMsgBox quot现在剩下:quot amp 30 - RemainDay amp quot试用次数,好好珍惜!quotRemainDay RemainDay 1SaveSetting quotMyAppquot quotsetquot quottimesquot RemainDayEnd Sub时间限制的(如30天)Private Sub Form_LoadDim RemainDay As LongRemainDay GetSettingquotMyAppquot quotsetquot quotdayquot 0If RemainDay 30 Then MsgBox quot试用期已过,请注册quot Unload MeEnd IfMsgBox quot现在剩下:quot amp 30 - RemainDay amp quot试用天数,好好珍惜!quotif daynow-remaindaygt0 then RemainDay RemainDay 1SaveSetting quotMyAppquot quotsetquot quottimesquot RemainDayEnd SubMMControl 控件全屏播放Option ExplicitPrivate Declare Function mciSendString Lib quotwinmm.dllquot _ Alias quotmciSendStringAquot ByVal lpstrCommand As _ String ByVal lpstrReturnString As Any ByVal _ uReturnLength As Long ByVal hwndCallback As _ Long As LongPrivate Declare Function mciSendCommand Lib quotwinmm.dllquot _ Alias quotmciSendCommandAquot ByVal wDeviceID As Long _ ByVal uMessage As Long ByVal dwParam1 As Long _ dwParam2 As MCI_OVLY_RECT_PARMS As LongPrivate Declare Function GetShortPathName Lib quotkernel32quot _ Alias quotGetShortPathNameAquot ByVal lpszLongPath As _ String ByVal lpszShortPath As String ByVal _ cchBuffer As Long As LongPrivate Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Type MCI_OVLY_RECT_PARMS dwCallback As Long rc As RECTEnd TypeConst MCI_OVLY_WHERE_SOURCE ampH20000Const MCI_OVLY_WHERE_DESTINATION ampH40000Const MCI_WHERE ampH843Dim Play As BooleanPrivate Sub Form_Load MMControl1.Wait True MMControl1.UpdateInterval 50 MMControl1.hWndDisplay Picture1.hWnd Picture1.ScaleMode 3 Timer1.Interval 50End SubPrivate Sub Form_UnloadCancel As Integer MMControl1.Command quotstopquot MMControl1.Command quotclosequotEnd SubPrivate Sub Command1_Click MMControl1.Command quotstopquot MMControl1.Command quotclosequot Play False CommonDialog1.Filter quotVB-Dateien .avi.aviquot CommonDialog1.InitDir App.Path CommonDialog1.ShowOpen If CommonDialog1.filename ltgt quotquot Then MMControl1.DeviceType quotavivideoquot MMControl1.filename CommonDialog1.filename MMControl1.Command quotopenquot 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 IfEnd SubPrivate Sub Command2_Click If Not Option3.Value Then If Play False And MMControl1.filename ltgt quotquot Then MMControl1.Command quotplayquot Play True End If Else Call Option3_Click End IfEnd SubPrivate Sub Command3_Click Play False MMControl1.Command quotstopquotEnd SubPrivate Sub Command4_Click MMControl1.Command quotpausequotEnd SubPrivate Sub MMControl1_DoneNotifyCode As Integer If Play And Check1.Value vbChecked Then Play False MMControl1.Command quotstopquot MMControl1.Command quotprevquot MMControl1.Command quotplayquot Play True End IfEnd SubPrivate Sub MMControl1_StatusUpdate Label2.Caption MMControl1.PositionEnd SubPrivate Sub Option1_Click Check1.Enabled True Check2.Enabled False MMControl1.hWndDisplay 0End SubPrivate Sub Option2_Click Check1.Enabled True Check2.Enabled True MMControl1.hWndDisplay Picture1.hWndEnd SubPrivate Sub Option3_Click‘-----------注意这里 Dim Ramp AA Check1.Enabled False Check2.Enabled False MMControl1.Command quotstopquot Play False AA Space255 R GetShortPathNameCommonDialog1.filename AA LenAA AA MidAA 1 R R mciSendStringquotplay quot amp AA amp quot fullscreen quot 0amp 0 0ampEnd SubPrivate Sub Check2_Click If Check2.Value vbChecked And MMControl1.filename ltgt quotquot Then Call AdaptPicture End IfEnd SubPrivate Sub Timer1_Timer Dim x AA x MMControl1.Mode Select Case x Case 524: AA quotNotOpenquot Case 525: AA quotStopquot Case 526: AA quotPlayquot Case 527: AA quotRecordquot Case 528: AA quotSeekquot Case 529: AA quotPausequot Case 530: AA quotReadyquot End Select Label6.Caption AAEnd SubPrivate Sub AdaptPicture Dim Resultamp Par As MCI_OVLY_RECT_PARMS Par.dwCallback MMControl1.hWnd Result mciSendCommandMMControl1.DeviceID _ MCI_WHERE MCI_OVLY_WHERE_SOURCE Par If Result ltgt 0 Then MsgBox quotFehlerquot Else Picture1.Width Par.rc.Right - Par.rc.Left 15 4 15 Picture1.Height Par.rc.Bottom - Par.rc.Top 15 4 15 End IfEnd Sub通用对话框专辑(全)使用 API 调用 Winodws 各种通用对话框Common Diaglog的方法(一)1.文件属性对话框Type SHELLEXECUTEINFOcbSize As LongfMask As Longhwnd As LonglpVerb As StringlpFile As StringlpParameters As StringlpDirectory As StringnShow As LonghInstApp As LonglpIDList As Long 可选参数lpClass As String 可选参数hkeyClass As Long 可选参数dwHotKey As Long 可选参数hIcon As Long 可选参数hProcess As Long 可选参数End TypeConst SEE_MASK_INVOKEIDLIST ampHCConst SEE_MASK_NOCLOSEPROCESS ampH40Const SEE_MASK_FLAG_NO_UI ampH400Declare Function ShellExecuteEX Lib quotshell32.dllquot Alias quotShellExecuteExquot _SEI As SHELLEXECUTEINFO As LongPublic Function ShowPropertiesfilename As String OwnerhWnd As Long AsLong打开指定文件的属性对话框如果返回值lt32 则出错Dim SEI As SHELLEXECUTEINFODim r As LongWith SEI.cbSize LenSEI.fMask SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST OrSEE_MASK_FLAG_NO_UI.hwnd OwnerhWnd.lpVerb quotpropertiesquot.lpFile filename.lpParameters vbNullChar.lpDirectory vbNullChar.nShow 0.hInstApp 0.lpIDList 0End Withr ShellExecuteEXSEIShowProperties SEI.hInstAppEnd Function新建一个工程添加一个按钮和名为 Text1 的文本框把以下代码置入 CommandbButton_Click 中Dim r As LongDim fname As String从 Text1 中获取文件名及路径fname Text1r ShowPropertiesfname Me.hwndIf r lt 32 Then MsgBox quotErrorquot2.使用 Win95 的关于对话框Private Declare Function ShellAbout Lib quotshell32.dllquot _Alias quotShellAboutAquot ByVal hwnd As Long ByVal szApp As String _ByVal szOtherStuff As String ByVal hIcon As Long As Long示例:Dim x As Longx shellabout Form1.hwnd quotVisual Basic 6.0quot _quotAlp Studio MouseTracker Ver 1.0quot Form1.icon2.调用quot捕获打印机端口quot对话框Private Declare Function WNetConnectionDialog Lib quotmpr.dllquot _ByVal hwnd As Long ByVal dwType As Long As Long示例:Dim x As Longx WNetConnectionDialogMe.hwnd 23.调用颜色对话框Private Type ChooseColorlStructSize As LonghwndOwner As LonghInstance As LongrgbResult As LonglpCustColors As Stringflags As LonglCustData As LonglpfnHook As LonglpTemplateName As StringEnd TypePrivate Declare Function ChooseColor Lib quotcomdlg32.dllquot Alias quotChooseColorAquotpChoosecolor As ChooseColor As Long将以下代码置入某一事件中:Dim cc As ChooseColorDim CustColor16 As Longcc.lStructSize Lencccc.hwndOwner Form1.hWndcc.hInstance App.hInstancecc.flags 0cc.lpCustColors String16 4 0Dim aDim xDim c1Dim c2Dim c3Dim c4a ChooseColorccClsIf a ThenMsgBox quotColor chosen:quot amp Strcc.rgbResultFor x 1 To Lencc.lpCustColors Step 4c1 AscMidcc.lpCustColors x 1c2 AscMidcc.lpCustColors x 1 1c3 AscMidcc.lpCustColors x 2 1c4 AscMidcc.lpCustColors x 3 1CustColorx / 4 c1 c2 256 c3 65536 c4 16777216MsgBox quotCustom Color quot amp Intx / 4 amp quot quot amp CustColorx / 4Next xElseMsgBox quotCancel was pressedquotEnd If4.调用复制磁盘对话框Private Declare Function SHFormatDrive Lib quotshell32quot ByVal hwnd As LongByVal Drive As Long ByVal fmtID As Long ByVal options As Long As LongPrivate Declare Function GetDriveType Lib quotkernel32quot Alias quotGetDriveTypeAquotByVal nDrive As String As Long示例:向窗体中添加一个名为 Drive1 的 DriveListBox将以下代码置入某一事件中Dim DriveLetter DriveNumberamp DriveTypeampDim RetValamp RetFromMsgampDriveLetter UCaseDrive1.DriveDriveNumber AscDriveLetter - 65DriveType GetDriveTypeDriveLetterIf DriveType 2 Then Floppies etcRetVal Shellquotrundll32.exe diskcopy.dllDiskCopyRunDll quot _amp DriveNumber amp quotquot amp DriveNumber 1 Notice space afterElse Just in case DiskCopyRunDllRetFromMsg MsgBoxquotOnly floppies canquot amp vbCrLf amp _quotbe diskcopiedquot 64 quotDiskCopy ExamplequotEnd If5.调用格式化软盘对话框Private Declare Function SHFormatDrive Lib quotshell32quot ByVal hwnd As LongByVal Drive As Long ByVal fmtID As Long ByVal options As Long As LongPrivate Declare Function GetDriveType Lib quotkernel32quot Alias quotGetDriveTypeAquotByVal nDrive As String As Long参数设置:fmtID-3.5quot 5.25quot-------------------------0 1.44M 1.2M1 1.44M 1.2M2 1.44M 1.2M3 1.44M 360K4 1.44M 1.2M5 720K 1.2M6 1.44M 1.2M7 1.44M 1.2M8 1.44M 1.2M9 1.44M 1.2M选项0 快速1 完全2 只复制系统文件3 只复制系统文件4 快速5 完全6 只复制系统文件7 只复制系统文件8 快速9 完全示例:要求同上Dim DriveLetter DriveNumberamp DriveTypeampDim RetValamp RetFromMsgDriveLetter UCaseDrive1.DriveDriveNumber AscDriveLetter - 65 Change letter to Number: A0DriveType GetDriveTypeDriveLetterIf DriveType 2 Then Floppies etcRetVal SHFormatDriveMe.hwnd DriveNumber 0amp 0ampElseRetFromMsg MsgBoxquotThis drive is NOT a removeablequot amp vbCrLf amp _quotdrive Format this drivequot 276 quotSHFormatDrive ExamplequotSelect Case RetFromMsgCase 6 Yes UnComment to do it...RetVal SHFormatDriveMe.hwnd DriveNumber 0amp 0ampCase 7 No Do nothingEnd SelectEnd If-----------------------------------------------------------------------------使用 API 调用 Winodws 各种通用对话框Common Diaglog的方法(二)1.选择目录/文件夹对话框将以下代码置于一模块中Option Explicit 调用方式:: string BrowseForFoldersHwndTitleOfDialog 例如:String1 BrowseForFoldersHwnd quotSelect target folder...quotPublic Type BrowseInfohwndOwner As LongpIDLRoot As LongpszDisplayName As LonglpszTitle As LongulFlags As LonglpfnCallback As LonglParam As LongiImage As LongEnd TypePublic Const BIF_RETURNONLYFSDIRS 1Public Const MAX_PATH 260Public Declare Sub CoTaskMemFree Lib quotole32.dllquot ByVal hMem As LongPublic Declare Function lstrcat Lib quotkernel32quot Alias quotlstrcatAquot ByVal lpString1As String ByVal lpString2 As String As LongPublic Declare Function SHBrowseForFolder Lib quotshell32quot lpbi As BrowseInfoAs LongPublic Declare Function SHGetPathFromIDList Lib quotshell32quot ByVal pidList AsLong ByVal lpBuffer As String As LongPublic Function BrowseForFolderhwndOwner As Long sPrompt As String AsStringDim iNull As IntegerDim lpIDList As LongDim lResult As LongDim sPath As StringDim udtBI As BrowseInfo初始化变量With udtBI.hwndOwner hwndOwner.lpszTitle lstrcatsPrompt quotquot.ulFlags BIF_RETURNONLYFSDIRSEnd With调用 APIlpIDList SHBrowseForFolderudtBIIf lpIDList ThensPath StringMAX_PATH 0lResult SHGetPathFromIDListlpIDList sPathCall CoTaskMemFreelpIDListiNull InStrsPath vbNullCharIf iNull Then sPath LeftsPath iNull - 1End If如果选择取消 sPath quotquotBrowseForFolder sPathEnd Function2.调用quot映射网络驱动器quot对话框Private/Public Declare Function WNetConnectionDialog Lib quotmpr.dllquot _ByVal hwnd As Long ByVal dwType As Long As Longx WNetConnectionDialogMe.hwnd 13.调用quot打开文件quot对话框Private Type OPENFILENAMElStructSize As LonghwndOwner As LonghInstance As LonglpstrFilter As StringlpstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LonglpstrFile As StringnMaxFile As LonglpstrFileTitle As StringnMaxFileTitle As LonglpstrInitialDir As StringlpstrTitle As Stringflags As LongnFileOffset As Integ.