|
不错VB代码，收藏！！！ 收藏
实现毫秒精度的延时
'Module Code:
Option Explicit Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Declare Function QueryPerformanceCounter Lib "kernel32" _ (lpPerformanceCount As LARGE_INTEGER) As Long Type LARGE_INTEGER LowPart As Long HighPart As Long End Type '实现毫秒量级精确延时,(n 毫秒)
Public Sub Wait(ByVal n As Long) Dim PFrequency As LARGE_INTEGER Dim Interval As LARGE_INTEGER Dim Privious As LARGE_INTEGER Dim Current As LARGE_INTEGER '获得高精度计数器的频率 QueryPerformanceFrequency PFrequency '获得高精度运行计数器的值 QueryPerformanceCounter Privious Current = Privious Interval.LowPart = (PFrequency.LowPart / 1000) * n '下面这句可以精确到微秒,好像不太实用,也未必精确到如此地步 'Interval.LowPart = (PFrequency.LowPart / 1000000) * n Interval.HighPart = 0 '通过比较两次计数器的值差实现高精度延时 Do While (Abs(Current.HighPart * 2 ^ 16) + Current.LowPart) - _ (Abs(Privious.HighPart * 2 ^ 16) + Privious.LowPart) < _ (Abs(Interval.HighPart * 2 ^ 16) + Interval.LowPart) QueryPerformanceCounter Current '此句若省略,循环期间其它事就都不能做了 DoEvents Loop End Sub 'Form Code: Option Explicit Dim l As Long
Private Sub Command1_Click()
l = 0 '对照时钟计时(它并不很精确,这里仅对照而已) '间隔10毫秒已经很小了 Timer1.Interval = 10 '延时 Wait 5000 '停止计时 Timer1.Interval = 0 MsgBox "你够狠,憋了我5000毫秒才放出来" End Sub Private Sub Form_Load()
'共三个控件:一个时钟,一个标签,一个按钮 Command1.Caption = "等待5000毫秒" Label1.AutoSize = True Label1.Caption = "这里是时钟计时" End Sub Private Sub Timer1_Timer()
l = l + 10 Label1.Caption = l End Sub -------------------------------------------------------
VB未公开的三个函数ObjPtr,StrPtr,VarPtr
'Form Code:
'ObjPtr: 返回对象实例私有域的地址
'StrPtr: 返回字符串第一个字的地址 'VarPtr: 返回变量的地址 '使用对象浏览器（Object Browser），你可以发现更多其他对象未公开的细节。
'使用诸如金山游侠之类的游戏修改器可以跟踪到这个变量的地址(查99887766数值) '需生成EXE,这样容易操作,不会受到VB6干扰 Dim l As Long Private Sub Command1_Click()
Print "对象实例私有域:", ObjPtr(Command1) Dim str As String str = "字符串第一个字的地址:" Print str, StrPtr(str) Print "----------------------------------" Dim ramid As Double ramid = VarPtr(l) l = 99887766 Print "变量的内存地址:", VarPtr(l) Print "转换成十六进制:", Hex(ramid) Print "变量 l 的值:", l End Sub Private Sub Form_Load()
'为了能持久显示,便于查看 Me.AutoRedraw = True End Sub 'VarPtr用在包含字符串的变量时,可能返回的指针是临时地址(UNICODE转换的缘故) 'StrPtr还是唯一能直观地告诉你空字符串和null字符串的不同的方法。 '对于null字符串(vbNullString)，StrPtr的返回值为0，而对于空字符串，函数的返回值为非零 '详细信息请查阅相关文档 ------------------------------------------------------------ '返回阿拉伯数字的中文大写或者普通写法的一个函数
Public Function ChnNumber(Number As Double, _ Optional Capital As Boolean = False, _ Optional Simple As Boolean = False) As String '返回阿拉伯数字的中文大写或者普通写法 '调用方法例如:Debug.Print ChnNumber(12300.43) '返回:壹萬贰仟叁佰点肆叁 ' Debug.Print ChnNumber(12300.43, 1) '返回:一万二千三百点四三 ' Debug.Print ChnNumber(12300.43, , 1) '返回:一二三○○点四三 '作者:csdngoodnight 'E-mail:kxufeng@163.com 'Number:阿拉伯数字(12300.43) 'Capital:True为中文大写(壹萬贰仟叁佰点肆叁),默认为False普通(一万二千三百点四三) 'Simple:True为简单排列(壹贰叁零零点肆叁/一二三○○点四三) If Abs(Number) > CDbl(9.99999999999999E+15) Then '9999兆9999万9990 or 9999999999999990 or 9.99999999999999E+15 MsgBox "超出这个范围的数字,将会有四舍五入进位情况。" & Space(5) & vbCrLf & _ "难道你...要计算星星的数量?偶帮不了你啦 :(", vbInformation, "老兄:天文数字啊" 'Exit Function End If Dim varNumber As Variant Dim ChnString(1) As String, strClass(1) As String Dim iNumberLen As Integer, iCapital As Integer Dim boolZero As Boolean Dim strTemp As String Dim i As Integer, j As Integer strClass(0) = "十百千万亿兆" strClass(1) = "拾佰仟萬億兆" ChnString(0) = "○一二三四五六七八九" ChnString(1) = "零壹贰叁肆伍陆柒捌玖" varNumber = Split(Format(Number, "0.################"), ".") iNumberLen = Len(varNumber(0)) If Number < 0 Then varNumber(0) = Right$((varNumber(0)), iNumberLen - 1) iNumberLen = iNumberLen - 1 End If iCapital = Abs(CInt(Capital)) If Simple Then For i = 1 To iNumberLen j = CInt(Mid$(varNumber(0), i, 1)) ChnNumber = ChnNumber & Mid$(ChnString(iCapital), j + 1, 1) Next If UBound(varNumber) > 0 Then iNumberLen = Len(varNumber(1)) For i = 1 To iNumberLen j = CInt(Mid$(varNumber(1), i, 1)) strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1) Next End If If Len(strTemp) > 0 Then ChnNumber = ChnNumber & "点" & strTemp If Number < 0 Then ChnNumber = "[负]" & ChnNumber Exit Function End If If iNumberLen < 2 Then If iNumberLen = 0 Then varNumber(0) = "0" ChnNumber = Mid$(ChnString(iCapital), CInt(varNumber(0)) + 1, 1) Else For i = 0 To iNumberLen - 1 j = CInt(Mid$(varNumber(0), iNumberLen - i, 1)) strTemp = Mid$(ChnString(iCapital), j + 1, 1) If j = 0 Then If boolZero = True Then strTemp = "" If i Mod 4 = 0 Then strTemp = "" boolZero = True If i > 0 Then strTemp = Mid$(strClass(iCapital), i / 4 + 3, 1) If iNumberLen - i > 4 Then If CInt(Right$(Left$(varNumber(0), iNumberLen - i), 4)) = 0 Then strTemp = "" End If End If End If If strTemp = "零" And Capital Then boolZero = True If strTemp = "○" And Not Capital Then boolZero = True Else boolZero = False If i Mod 4 = 0 Then '万亿兆 j = i / 4 Mod 3 If j = 0 Then j = 6 Else j = j + 3 '可能出现的天文数字 If i > 0 Then strTemp = strTemp & Mid$(strClass(iCapital), j, 1) Else '十百千位 strTemp = strTemp & Mid$(strClass(iCapital), i Mod 4, 1) End If End If ChnNumber = strTemp & ChnNumber strTemp = "" Next End If '处理小数部分 If UBound(varNumber) > 0 Then iNumberLen = Len(varNumber(1)) For i = 1 To iNumberLen j = CInt(Mid$(varNumber(1), i, 1)) strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1) Next End If If Len(strTemp) > 0 Then ChnNumber = ChnNumber & "点" & strTemp If Number < 0 Then ChnNumber = "[负数]" & ChnNumber End Function 系统托盘图标 例2 将下列文件恢复后:form1.picture1中载入一个图标,运行 【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】
Type=Exe Class=CTray; CTray.cls Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation Form=Form1.frm Startup="Form1" HelpFile="" Command32="" Name="工程1" HelpContextID="0" CompatibleMode="0" MajorVer=1 MinorVer=0 RevisionVer=0 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="xufeng" CompilationType=0 OptimizationType=0 FavorPentiumPro(tm)=0 CodeViewDebugInfo=0 NoAliasing=0 BoundsCheck=0 OverflowCheck=0 FlPointCheck=0 FDIVCheck=0 UnroundedFP=0 StartMode=0 Unattended=0 Retained=0 ThreadPerObject=0 MaxNumberOfThreads=1 [MS Transaction Server]
AutoRefresh=1 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Form1 Caption = "本例演示托盘图标" ClientHeight = 3090 ClientLeft = 165 ClientTop = 855 ClientWidth = 4680 Icon = "Form1.frx":0000 LinkTopic = "Form1" ScaleHeight = 3090 ScaleWidth = 4680 StartUpPosition = 3 '窗口缺省 Begin VB.PictureBox Picture1 Height = 735 Left = 720 Picture = "Form1.frx":000C ScaleHeight = 675 ScaleWidth = 915 TabIndex = 0 Top = 600 Width = 975 End Begin VB.Menu tempmenu Caption = "托盘菜单" Begin VB.Menu m_open Caption = "打开 " Shortcut = ^O End Begin VB.Menu m_save Caption = "保存" Shortcut = ^S End Begin VB.Menu m_11 Caption = "-" End Begin VB.Menu m_exit Caption = "关闭" Shortcut = ^Q End End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim WithEvents Tray As CTray
Attribute Tray.VB_VarHelpID = -1 Private Sub Form_Load()
'托盘图标 Set Tray = New CTray With Tray .TipText = Me.Caption '提示文本 .PicBox = Picture1 '一个用于托盘的图标(PictureBox) End With Tray.ShowIcon '添加图标在托盘 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'删除托盘图标 Tray.DeleteIcon Set Tray = Nothing End Sub Private Sub m_exit_Click()
Unload Me End Sub '以下为托盘图标事件
Private Sub Tray_LButtonDblClick() '左键双击 End Sub Private Sub Tray_LButtonDown()
'左键按下 End Sub Private Sub Tray_LButtonUp()
'左键放开 End Sub Private Sub Tray_RButtonDblClick()
'右键双击 End Sub Private Sub Tray_RButtonDown()
'右键按下 End Sub Private Sub Tray_RButtonUp()
'右键放开 PopupMenu tempmenu End Sub 【Class Code:将下面代码用记事本保存为 CTray.cls(类模块文件),此括弧及括弧内容除外】 VERSION 1.0 CLASS
BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CTray" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '------------------------------------------------------------------- '类模块:托盘图标的添加 '------------------------------------------------------------------- Option Explicit
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pNid As NOTIFYICONDATA) As Boolean Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1 Private Const NIM_DELETE = &H2 Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2 Private Const NIF_TIP = &H4 Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Private Const WM_LBUTTONDBLCLK = &H203 Private Const WM_RBUTTONDOWN = &H204 Private Const WM_RBUTTONUP = &H205 Private Const WM_RBUTTONDBLCLK = &H206 Private Type NOTIFYICONDATA
lSize As Long hWnd As Long lId As Long lFlags As Long lCallBackMessage As Long hIcon As Long szTip As String * 64 End Type Private mNID As NOTIFYICONDATA
Private WithEvents mPic As PictureBox Attribute mPic.VB_VarHelpID = -1 Public Event RButtonDown() '鼠标右键按下
Public Event RButtonUp() '鼠标右键放开 Public Event RButtonDblClick() '鼠标右键双击 Public Event LButtonDown() '鼠标左键按下 Public Event LButtonUp() '鼠标左键放开 Public Event LButtonDblClick() '鼠标左键双击 Private Sub Class_Initialize()
With mNID .lSize = Len(mNID) .lCallBackMessage = WM_MOUSEMOVE .lFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE .lId = 1& End With End Sub Private Sub Class_Terminate()
DeleteIcon Set mPic = Nothing End Sub Public Property Let PicBox(ByVal PicBox As PictureBox)
Set mPic = PicBox With mNID .hWnd = mPic.hWnd .hIcon = mPic End With End Property Public Property Get TipText() As String
TipText = mNID.szTip End Property Public Property Let TipText(ByVal TipText As String)
mNID.szTip = TipText & Chr$(0) Shell_NotifyIcon NIM_MODIFY, mNID End Property Public Function ShowIcon() As Boolean
If mPic Is Nothing Then ShowIcon = False Else Shell_NotifyIcon NIM_ADD, mNID ShowIcon = True End If End Function Public Sub DeleteIcon()
Shell_NotifyIcon NIM_DELETE, mNID End Sub Private Sub mPic_Change()
mNID.hIcon = mPic Shell_NotifyIcon NIM_MODIFY, mNID End Sub Private Sub mPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static bRec As Boolean Dim lMsg As Long lMsg = X / Screen.TwipsPerPixelX
If bRec = False Then
bRec = True Select Case lMsg Case WM_LBUTTONDBLCLK: '左键双击 RaiseEvent LButtonDblClick Case WM_LBUTTONDOWN: '左键按下 RaiseEvent LButtonDown Case WM_LBUTTONUP: '左键放开 RaiseEvent LButtonUp Case WM_RBUTTONDBLCLK: '右键双击 RaiseEvent RButtonDblClick Case WM_RBUTTONDOWN: '右键按下 RaiseEvent RButtonDown Case WM_RBUTTONUP: '右键放开 RaiseEvent RButtonUp End Select bRec = False End If End Sub Shell 函数的几个示例 'Form Code: '执行一个可执行文件，返回一个 Variant (Double)，
'如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。 '语法
'Shell(pathname[,windowstyle]) 'Shell 函数的语法含有下面这些命名参数:
'部分 描述
'pathname 必要参数。Variant (String)，要执行的程序名，以及任何必需的参数或命令行变量， _ 可能还包括目录或文件夹，以及驱动器。 'Windowstyle 可选参数。Variant (Integer)，表示在程序运行时窗口的样式。 _ 如果 windowstyle 省略，则程序是以具有焦点的最小化窗口来执行的。 'windowstyle 命名参数有以下这些值: '常数 值 描述 'vbHide 0 窗口是隐藏的，并且焦点被传递给隐藏窗口。 'vbNormalFocus 1 窗口拥有焦点，并且恢复到原来的大小与位置。 'vbMinimizedFocus 2 窗口缩小为图符并拥有焦点。 'vbMaximizedFocus 3 窗口最大化并拥有焦点。 'vbNormalNoFocus 4 窗口被恢复到最近一次的大小与位置。当前活动窗口仍为活动窗口。 'vbMinimizeNoFocus 6 窗口缩小为图符。当前活动窗口仍为活动窗口。 Private Sub Command1_Click()
'如果指定文件夹不存在,则创建 If Dir("c:\mydos", vbDirectory) = "" Then MkDir "c:\mydos" '在硬盘上新建一个c:\mydos的文件夹。 '调用指令,复制一批文件到该文件夹下(需具备xcopy.exe) Shell "xcopy.exe C:\WINDOWS\Web\Wallpaper\*.* c:\mydos/s/e", vbHide '使用浏览器打开该目录 Shell "explorer.exe " & "c:\mydos", vbNormalFocus End Sub Private Sub Command2_Click()
'把DOS应用程序的屏幕输出写到一个文件中去。 '例如用下列代码可把DOS命令copy的帮助信息写到一个文件中去。 Open "c:\test.bat" For Output As #1 '建立批处理文件 Print #1, "copy/?>c:\copyhelp.txt" Print #1, "@exit" Close #1 '执行这个批处理文件 Shell "c:\test.bat", vbHide '最后一句必须是@exit，不然经Shell调用后的批处理文件无法从内存中退出 End Sub ---------------------------------------
托盘图标 例1 将下列文件恢复后:form1.icon中载入一个图标,运行 【Project Code:将下面代码用记事本保存为 PROJECT1.vbp(VB工程文件),此括弧及括弧内容除外】 Type=Exe Form=Form1.frm Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation Module=APIStuff; Apistuff.bas IconForm="Form1" Startup="Form1" Command32="" Name="Project1" HelpContextID="0" CompatibleMode="0" MajorVer=1 MinorVer=0 RevisionVer=0 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="Rocky Mountain Computer Consulting, Inc." CompilationType=0 OptimizationType=0 FavorPentiumPro(tm)=0 CodeViewDebugInfo=0 NoAliasing=0 BoundsCheck=0 OverflowCheck=0 FlPointCheck=0 FDIVCheck=0 UnroundedFP=0 StartMode=0 Unattended=0 Retained=0 ThreadPerObject=0 MaxNumberOfThreads=1 [MS Transaction Server]
AutoRefresh=1 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 4710 ClientLeft = 1635 ClientTop = 1830 ClientWidth = 7665 Icon = "Form1.frx":0000 LinkTopic = "Form1" ScaleHeight = 4710 ScaleWidth = 7665 ShowInTaskbar = 0 'False Begin VB.Menu mnuFile Caption = "文件" Begin VB.Menu mnuFileExit Caption = "退出" End End Begin VB.Menu mnuTray Caption = "Popup" Visible = 0 'False Begin VB.Menu mnuTrayRestore Caption = "恢复" End Begin VB.Menu mnuTrayMove Caption = "移动" End Begin VB.Menu mnuTraySize Caption = "大小" End Begin VB.Menu mnuTrayMinimize Caption = "最小化" End Begin VB.Menu mnuTrayMaximize Caption = "最大化" End Begin VB.Menu mnuTraySep Caption = "-" End Begin VB.Menu mnuTrayClose Caption = "关闭" End End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Public LastState As Integer
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_SYSCOMMAND = &H112 Private Const SC_MOVE = &HF010& Private Const SC_RESTORE = &HF120& Private Const SC_SIZE = &HF000& Private Sub Form_Load()
If WindowState = vbMinimized Then LastState = vbNormal Else LastState = WindowState End If AddToTray Me, mnuTray SetTrayTip "VB Helper tray icon program" End Sub Private Sub Form_Resize()
Select Case WindowState Case vbMinimized mnuTrayMaximize.Enabled = True mnuTrayMinimize.Enabled = False mnuTrayMove.Enabled = False mnuTrayRestore.Enabled = True mnuTraySize.Enabled = False Case vbMaximized mnuTrayMaximize.Enabled = False mnuTrayMinimize.Enabled = True mnuTrayMove.Enabled = False mnuTrayRestore.Enabled = True mnuTraySize.Enabled = False Case vbNormal mnuTrayMaximize.Enabled = True mnuTrayMinimize.Enabled = True mnuTrayMove.Enabled = True mnuTrayRestore.Enabled = False mnuTraySize.Enabled = True End Select If WindowState <> vbMinimized Then _
LastState = WindowState End Sub Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray End Sub Private Sub mnuFileExit_Click()
Unload Me End Sub Private Sub mnuTrayClose_Click()
Unload Me End Sub Private Sub mnuTrayMaximize_Click()
WindowState = vbMaximized End Sub Private Sub mnuTrayMinimize_Click()
WindowState = vbMinimized End Sub Private Sub mnuTrayMove_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_MOVE, 0& End Sub Private Sub mnuTrayRestore_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0& End Sub Private Sub mnuTraySize_Click()
SendMessage hwnd, WM_SYSCOMMAND, SC_SIZE, 0& End Sub (待续)
(续) 【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】
Attribute VB_Name = "APIStuff" Option Explicit Public OldWindowProc As Long
Public TheForm As Form Public TheMenu As Menu 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _ (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202 Public Const WM_MBUTTONUP = &H208 Public Const WM_RBUTTONUP = &H205 Public Const TRAY_CALLBACK = (WM_USER + 1001&) Public Const GWL_WNDPROC = (-4) Public Const GWL_USERDATA = (-21) Public Const NIF_ICON = &H2 Public Const NIF_TIP = &H4 Public Const NIM_ADD = &H0 Public Const NIF_MESSAGE = &H1 Public Const NIM_MODIFY = &H1 Public Const NIM_DELETE = &H2 Public Type NOTIFYICONDATA
cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 64 End Type Private TheData As NOTIFYICONDATA
Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = TRAY_CALLBACK Then If lParam = WM_LBUTTONUP Then If TheForm.WindowState = vbMinimized Then _ TheForm.WindowState = TheForm.LastState TheForm.SetFocus Exit Function End If If lParam = WM_RBUTTONUP Then TheForm.PopupMenu TheMenu Exit Function End If End If NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam) End Function Public Sub AddToTray(frm As Form, mnu As Menu)
Set TheForm = frm Set TheMenu = mnu OldWindowProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc) With TheData .uID = 0 .hwnd = frm.hwnd .cbSize = Len(TheData) .hIcon = frm.Icon.Handle .uFlags = NIF_ICON .uCallbackMessage = TRAY_CALLBACK .uFlags = .uFlags Or NIF_MESSAGE .cbSize = Len(TheData) End With Shell_NotifyIcon NIM_ADD, TheData End Sub Public Sub RemoveFromTray()
With TheData .uFlags = 0 End With Shell_NotifyIcon NIM_DELETE, TheData SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc End Sub Public Sub SetTrayTip(tip As String)
With TheData .szTip = tip & vbNullChar .uFlags = NIF_TIP End With Shell_NotifyIcon NIM_MODIFY, TheData End Sub Public Sub SetTrayIcon(pic As Picture)
If pic.Type <> vbPicTypeIcon Then Exit Sub With TheData
.hIcon = pic.Handle .uFlags = NIF_ICON End With Shell_NotifyIcon NIM_MODIFY, TheData End Sub ---------------------------------------------------
几个小函数
'(作者:csdngoodnight,E-mail:kxufeng@163.com) Public Function LenBB(Expression As String) As Integer '取得字符串实际字节长度 LenBB = LenB(StrConv(Expression, vbFromUnicode)) End Function '-------------------------------------
'获得我的文档路径 '(作者:csdngoodnight,E-mail:kxufeng@163.com) Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pIdl As Long, ByVal pszPath As String) As Long Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _ (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long Type SHITEMID cb As Long abID() As Byte End Type Type ITEMIDLIST mkid As SHITEMID End Type Public Function MyDocumentsDir(oForm As Form) As String
Dim IDL As ITEMIDLIST Dim sPath As String * 260 If SHGetSpecialFolderLocation(oForm.hWnd, 5, IDL) = 0 Then If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then '返回我的文档路径 MyDocumentsDir = Left$(sPath, InStr(sPath, vbNullChar) - 1) End If End If End Function '----------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com)
Public Function RangeDiff(RangeNameA As String, RangeNameB As String) As Integer '返回两列间隔数(Excel表中的列) Dim a As Integer, b As Integer If Len(RangeNameA) = 0 Or Len(RangeNameB) = 0 Then Exit Function RangeNameA = UCase(RangeNameA) RangeNameB = UCase(RangeNameB) If Len(RangeNameA) = 1 Then a = Asc(RangeNameA) - 64 Else a = (Asc(Left(RangeNameA, 1)) - 64) * 26 + Asc(Right(RangeNameA, 1)) - 64 End If If Len(RangeNameB) = 1 Then b = Asc(RangeNameB) - 64 Else b = (Asc(Left(RangeNameB, 1)) - 64) * 26 + Asc(Right(RangeNameB, 1)) - 64 End If RangeDiff = b - a End Function '-----------------------------------------
'(作者:csdngoodnight,E-mail:kxufeng@163.com) Public Function FindRepeat(strChr As String) As String '判断字符串是否有重复字符 Dim i As Integer, j As Integer For i = 1 To Len(strChr) For j = 1 To Len(strChr) If j <> i Then If Mid(strChr, i, 1) = Mid(strChr, j, 1) Then FindRepeat = Mid(strChr, i, 1) Exit Function End If End If Next Next End Function '--------------------------------------------------- '(作者:csdngoodnight,E-mail:kxufeng@163.com) '配合上面那个LenBB函数使用 Public Function FileNameIs(AllFileDir As String, FileDirIs As String) As String '获取文件路径中的 路径部分 和 文件名部分 '调用: 'Dim filedir As String 'Debug.Print "文件名:", FileNameIs("c:\abc.txt", filedir) 'Debug.Print "路径:", filedir If Len(AllFileDir) = 0 Then FileDirIs = "": Exit Function
Dim v As Variant Dim i As Integer v = Split(AllFileDir, "\") i = UBound(v) '取得路径 FileDirIs = Left(AllFileDir, LenBB(AllFileDir) - LenBB(CStr(v(i))) - 1) '取得文件名 FileNameIs = v(i) End Function '---------------------------------------------------
检查窗口是否激活 Public OldWindowProc As Long
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 SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 'Const GWL_WNDPROC = (-4) Const WM_ACTIVATE = &H6
Const WA_ACTIVE = 1 Const WA_CLICKACTIVE = 2 Const WA_INACTIVE = 0 Public Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = WM_ACTIVATE Then If (wParam = WA_ACTIVE Or wParam = WA_CLICKACTIVE) Then '活动 debug.print "活动" Else '非活动 debug.print "不活动" End If End If NewWindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)
End Function '窗体load中加上此代码:
OldWindowProc = SetWindowLong(hWnd, (-4), AddressOf NewWindowProc) ----------------------------------------------------- 用API指定文件夹(对话框)
'Module Code:
Private Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260 Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _ (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" _ (ByVal pidList As Long, ByVal lpBuffer As String) As Long Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String Dim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo With udtBI
.hWndOwner = hWndOwner .lpszTitle = lstrcat(sPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS End With lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0) lResult = SHGetPathFromIDList(lpIDList, sPath) Call CoTaskMemFree(lpIDList) iNull = InStr(sPath, vbNullChar) If iNull Then
sPath = Left$(sPath, iNull - 1) End If End If BrowseForFolder = sPath
End Function 'Form Code: Private Sub Command1_Click() Dim sDirectoryName As String sDirectoryName = BrowseForFolder(Me.hWnd, "请选择目录") Debug.Print sDirectoryName End Sub ------------------------------------------------ 判定Variant变量值的类型
VarType 常数
语法: VarType(varname) 可在代码中的任何地方用下列常数代替实际值： 常数 值 描述
vbEmpty 0 未初始化（缺省值） vbNull 1 不含任何有效数据 vbInteger 2 Integer vbLong 3 长整数 vbSingle 4 单精度浮点数 vbDouble 5 双精度浮点数 vbCurrency 6 Currency vbDate 7 Date vbString 8 String vbObject 9 对象 vbError 10 错误 vbBoolean 11 布尔 vbVariant 12 Variant（只用于变体的数组类型） vbDataObject 13 数据访问对象 vbDecimal 14 Decimal vbByte 17 Byte vbUserDefinedType 36 包含用户定义类型的变量 vbArray 8192 数组 TypeName 函数 返回一个 String，提供有关变量的信息。 语法: TypeName(varname) 必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。
TypeName 所返回的字符串可以是下面列举的任何一个字符串： 返回字符串 变量
<object type> 类型为 objecttype 的对象
Byte 位值 Integer 整数 Long 长整数 Single 单精度浮点数 Double 双精度浮点数 Currency 货币 Decimal 十进制值 Date 日期 String 字符串 <Boolean> 布尔值:False 或 True Error 错误值 Empty 未初始化 Null 无效数据 Object 对象 Unknown 类型未知的对象 Nothing 不再引用对象的对象变量 如果 varname 是一个数组，则返回的字符串可以是任何一个后面添加了空括号的可能的返回字符串（或 Variant）。例如，如果 varname 是一个整数数组，则 TypeName 返回 "Integer()"。
-------------------------------------------------------- VB工程组成结构 文件扩展名及描述
.bas基本模块 .cls类模块 .ctl用户控件文件 .ctx用户控件的二进制文件 .dca活动的设计器的高速缓存 .ddf打包和扩展向导CAB信息文件 .dep打包和展开向导从属文件 .dll运行中的AvtiveX部件 .dobAvtiveX文档窗体文件 .doxAvtiveX文档二进制窗体文件 .dsr活动的设计器文件 .dsx活动的设计器的二进制文件 .dws部署向导教本文件 .exe可执行文件或AvtiveX部件 .frm窗体文件 .frx二进制窗体文件 .log加载错误的日志文件 .oca控件类型库缓存文件 .ocxAvtiveX控件 .pag属性页文件 .pgx二进制属性页文件 .res资源文件 .tlb远程自动化类型库文件 .vbdAvtiveX文档状态文件 .vbgVisual Basic组工程文件 .vbl控件许可文件 .vbpVisual Basic工程文件 .vbr远程自动化注册文件 .vbwVisual Basic工程工作空间文件 .vbz向导发射文件 .wctWebClass HTML模板 -----------------------------------------------
"!"感叹号与"."圆点的用法差异
都用在对象的属性等的引用上.
圆点操作符"."用来表示对象的属性和方法,在引用时需要用在对象的名称、圆点和需要的属性和方法.例如引用按钮的Caption属性:Command1.Caption
感叹号"!"常用于一个控件作为一个特性访问的情况下,例如引用另一窗体中的TextBox的Text属性:Form2!Text1.Text,用"!"连接两个控件,且前者是后者的容器.值得注意的是这里如果使用"."替换"!",可以获得同样效果.为了提高代码可读性,用"!"吧.
------------------------------------------ 动态数组相关
'介绍如何声明动态数组,以及保留动态数组的内容
'声明动态数组
Dim MyArray() As Integer Private Sub Form_Load() Dim i As Integer Dim j As Integer j = 5 '重定数组数维大小 ReDim MyArray(j) Debug.Print "当前数维:", UBound(MyArray) For i = 0 To j '初始化数组 MyArray(i) = i Debug.Print MyArray(i) Next '若要再次重定数维大小,而且要保留原有数据 '那么,用关键字 Preserve,但它只能重定最末维大小 j = j + 5 ReDim Preserve MyArray(j) Debug.Print "当前数维:", UBound(MyArray) '查看数据 For i = j - 5 To j MyArray(i) = i Debug.Print MyArray(i) Next Debug.Print "全部数据:" For i = 0 To j Debug.Print MyArray(i) Next End Sub ---------------------------------------------------- 遍历所有控件和判断控件类型
Private Sub Form_DblClick() '定义对象 Dim ctl As Control '遍历所有控件 For Each ctl In Me 'For Each ctl In Me.Controls '根据类型,改变属性值 If TypeOf ctl Is TextBox Then ctl.Text = "文本框" & ctl.Text ElseIf TypeOf ctl Is Label Then ctl.Caption = "标签" & ctl.Caption ElseIf TypeOf ctl Is CommandButton Then ctl.Caption = "按钮" & ctl.Caption End If Next End Sub VB的坐标系统综述 由于在visual basic系统中有多种坐标定义,容易使初学者混淆,本文将详细总结vb的坐标系统的一些基本概念，并提供坐标定义的详细方法： visual basic 坐标系统概述：
visual basic 的坐标系统是指在屏幕（screen）、窗体(form)、容器(container)上定义的表示图形对象位置的平面二维格线，一般采用数对（x,y）的形式定位。其中，x 值是沿 x 轴点的位置，最左端是缺省位置 0。y 值是沿 y 轴点的位置，最上端是缺省位置 0。
在visual basic坐标系中，沿坐标轴定义位置的测量单位，统称为刻度，坐标系统的每个轴都有自己的刻度。坐标轴的方向、起点和刻度都是可变的,在后面的叙述中，将讨论如何改变这些定义。
如何创建坐标系统:
创建图形对象的坐标系统，一般有以下几种方法：
1、使用系统缺省定义：
在系统缺省状态下，visual basic使用twips坐标系，以’缇’为单位(1缇的长度等于1/1440英寸；1/567厘米;1/20磅)。应当注意的是：这些值指示的是图形对象打印尺寸的大小。而在计算机屏幕上的物理距离则根据监视器的大小及分辨率的变化而变化。
2、选择系统标准刻度定义：
除了缺省的twips坐标系外，用户还可以通过对象的scalemode属性来设置其它的坐标刻度：（共有8种设置），现将这些设置列表如下：
scalemode值 表示 说明
0 user 用户自定义
1 twip 缇，系统缺省设置
2 point 磅，每英寸约为72磅
3 pixel 像素，像素是监视器或打印机分率的最小单位。每英寸里像素的数目由系统设备的分辨率决定。
4 character 字符，打印时，一个字符高 1/6 英寸，宽1/12 英寸
5 inch 英寸，每英寸为2.54厘米
6 millimeter 毫米
7 centimeter 厘米
在上述设置值中，除了 0 和 3以外，其它所有模式都是打印机所打印的单位长度。例如，某对象长为4个单位，当 scalemode 设为 5 时，打印时就是4英寸长。在程序中设定scalemode值的代码如下：
'设窗体的刻度单位为厘米。
scalemode = 7
'设 picture1 的刻度单位为像素。
picture1.scalemode = 3
3、创建自定义坐标系统：
当scalemode=0时，即为用户自定义模式，可采用设置对象的相应属性，来创建所需的坐标系统,这些属性是：
scaleleft: 设置对象左边距值
scaletop: 设置对象上边距值
scalewidth: 设置对象宽度
scaleheight: 设置对象高度
下面给出如下设置代码：
scaleleft=100
scaletop=100
scalewidth=300
scaleheight=200
picture1.scaleleft=50
picture1.scaletop=50
则所定义的坐标系如下图所示：
scaletop=100
picture1.scaleleft=50
以上代码定义窗体左上角坐标为（100，100），定义窗体内图形对象picture1距窗体左边距离为50，上边距离为50。scalewidth 和 scaleheight 语句定义窗体内部宽度的 1/300 为水平坐标单位；当前窗体内部高度的 1/200 为垂直坐标单位。如果窗体的大小以后被调整，这些单位保持原状。也就是说：scalewidth 和 scaleheight 是按照对象的内部尺寸来定义单位的，并且这些尺寸不包括边框厚度或菜单标题的高度。scalewidth 和 scaleheight 是指对象内的可用空间的大小。它们决定了对象本身的坐标系统。这有别于内部尺寸和外部尺寸（由 width 和 height属性指定）定义，width 和 height 总是按照容器的坐标系统来表示。另外以上刻度属性都可包括分数，也可是负数。如果将 scalewidth 和 scaleheight 属性设置值为负数即改变坐标系统的方向。
4．使用scale方法定义坐标系统：
一个更简洁的改变坐标系统的途径是使用 scale 方法。定义形式如下：
[object.]scale (x1, y1) – (x2, y2)
x1 和 y1 的值，决定了 scaleleft 和 scaletop 属性的设置值。x2-x1的差值和y2-y1的差值，分别决定了 scalewidth 和 scaleheight 属性的设置值。若指定 x1 > x2 或 y1 > y2 的值，与设置 scalewidth 或 scaleheight 为负值的效果相同。例如：设定窗体坐标系统如下：
scale (100, 100)-(200, 200)
该语句定义等同于以下属性设置：
scaletop=100:scaleleft=100:scalewidth=100:scaleheight=100
如何恢复缺省坐标系统：
在定义了其它坐标系后，如果需要将坐标系统恢复为缺省的twips坐标系，可以使用不含参数的scale方法，如语句：
picture1.scale
将图形对象的坐标系统恢复为缺省，其左上角坐标为（0，0）。
--------------------------------------------------------- 键码 键码 常数 值 描述
vbKeyLButton 1 鼠标左键 vbKeyRButton 2 鼠标右键 vbKeyCancel 3 CANCEL 键 vbKeyMButton 4 鼠标中键 vbKeyBack 8 BACKSPACE 键 vbKeyTab 9 TAB 键 vbKeyClear 12 CLEAR 键 vbKeyReturn 13 ENTER 键 vbKeyShift 16 SHIFT 键 vbKeyControl 17 CTRL 键 vbKeyMenu 18 菜单键 vbKeyPause 19 PAUSE 键 vbKeyCapital 20 CAPS LOCK 键 vbKeyEscape 27 ESC 键 vbKeySpace 32 SPACEBAR 键 vbKeyPageUp 33 PAGEUP 键 vbKeyPageDown 34 PAGEDOWN 键 vbKeyEnd 35 END 键 vbKeyHome 36 HOME 键 vbKeyLeft 37 LEFT ARROW 键 vbKeyUp 38 UP ARROW 键 vbKeyRight 39 RIGHT ARROW 键 vbKeyDown 40 DOWN ARROW 键 vbKeySelect 41 SELECT 键 vbKeyPrint 42 PRINT SCREEN 键 vbKeyExecute 43 EXECUTE 键 vbKeySnapshot 44 SNAP SHOT 键 vbKeyInser 45 INS 键 vbKeyDelete 46 DEL 键 vbKeyHelp 47 HELP 键 vbKeyNumlock 144 NUM LOCK 键 A 键到 Z 键与其 ASCII 码的相应值'A' 到 'Z' 是一致的 常数 值 描述 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 键与其 ASCII 码的相应值 '0' 到 '9' 是一致的 常数 值 描述 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 96 0 键 vbKeyNumpad1 97 1 键 vbKeyNumpad2 98 2 键 vbKeyNumpad3 99 3 键 vbKeyNumpad4 100 4 键 vbKeyNumpad5 101 5 键 vbKeyNumpad6 102 6 键 vbKeyNumpad7 103 7 键 vbKeyNumpad8 104 8 键 vbKeyNumpad9 105 9 键 vbKeyMultiply 106 乘号 (*) 键 vbKeyAdd 107 加号 (+) 键 vbKeySeparator 108 ENTER 键（在数字小键盘上） vbKeySubtract 109 减号 (-) 键 vbKeyDecimal 110 小数点 (.) 键 vbKeyDivide 111 除号 (/) 键 功能键 常数 值 描述 vbKeyF1 112 F1 键 vbKeyF2 113 F2 键 vbKeyF3 114 F3 键 vbKeyF4 115 F4 键 vbKeyF5 116 F5 键 vbKeyF6 117 F6 键 vbKeyF7 118 F7 键 vbKeyF8 119 F8 键 vbKeyF9 120 F9 键 vbKeyF10 121 F10 键 vbKeyF11 122 F11 键 vbKeyF12 123 F12 键 vbKeyF13 124 F13 键 vbKeyF14 125 F14 键 vbKeyF15 126 F15 键 vbKeyF16 127 F16 键 以下是我的一个安装包的注释内容: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ;下面的注释包含自解压脚本命令 Path=xufengn635 v2.0
SavePath Setup=xfn6353.exe Overwrite=1 Title=庆晓资料运算工具 2.0 安装程序 Text { 《庆晓资料运算工具 ver 2.0 最终用户许可协议》 首先你必须承认：世界上没有烤不熟的地瓜，以表明你与作者就 地瓜一事已达成共识。 其次，(此处略去) 联系作者：旭峰 E-mail: kxufeng@163.com } Shortcut=D, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0" Shortcut=P, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0" - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 用WinRar制作自释放压缩包,可以同样有安装界面,同样可以创建快捷键,可以有反安装项,仅把需要的几个部件加进去就行了.体积不会很大,适用于一些免费软件.上述安装包仅1.25M,一张软盘就可以带走.在win98-2上(没有装过任何VB类型程序的系统)运行都可以通过. 其中包括的组件及描述: xfn6353.exe主程序(form 3个,用户控件 2个,image 若干,picturebox 8个,Label 若干,combobox 若干,timer ...)704k MSVBVM60.DLL运行库(我们用的很多函数和一些基本控件,诸如Mid,UCase,Shell,Left,Right...都在里面) 1.34M PICCLP32.OCX因为做了个动画,用到了PictureClip,所以连控件一并打包 81.1k help.chm帮助文件 446k Sound目录有几个WAV在里面 40k n635.ico图标,工程和压缩包都用到(为了减小体积,要把图标文件中不需要的24X,48X,真彩色等图层全部去掉.仅保留16X 256色和32X 256色两层) 要注意的是,有些不能自我注册的Dll或OCX,可以写个BAT文件解压后自动运行执行注册:
regsvr32 abcd.dll rem regsvr32 /u abcd.dll @exit (那个regsvr32.exe要13k大小,第二行被注释掉的是反注册命令)
---------------------------------------------------------------
磁盘序号 'Form Code: Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" _ (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _ ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _ lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _ ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long 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 Private Sub form_load() '使用该函数: MsgBox GetSerialNumber("c:\") '它将告诉你C驱的磁盘序号。 End Sub -------------------------------------------------------- 获取所有驱动器类型
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Demo_Frm Caption = "Demo" ClientHeight = 2670 ClientLeft = 3795 ClientTop = 1905 ClientWidth = 4035 LinkTopic = "Form1" ScaleHeight = 2670 ScaleWidth = 4035 Tag = "hello" Begin VB.ListBox List1 Height = 2040 Left = 120 TabIndex = 1 Top = 240 Width = 3855 End Begin VB.CommandButton Command1 Caption = "获取信息" Height = 375 Left = 1440 TabIndex = 0 Top = 2280 Width = 975 End End Attribute VB_Name = "Demo_Frm" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _ (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long Private Declare Function GetLogicalDrives Lib "kernel32" () As Long Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_NO_ROOT_DIR = 1 Private Const DRIVE_REMOVABLE = 2 Private Const DRIVE_FIXED = 3 Private Const DRIVE_REMOTE = 4 Private Const DRIVE_CDROM = 5 Private Const DRIVE_RAMDISK = 6 ' 用来返回磁盘驱动器的个数
Public Function DriveCount() As Integer Dim BitMask As Long Dim j, i BitMask = GetLogicalDrives() For i = 0 To 24 If BitMask And 2 ^ i Then j = j + 1 End If Next i DriveCount = j End Function ' 返回驱动器的名称
Public Function LoadDrivenames(An_Array() As String) As Long Dim j, i Dim lpBuffer As String ReDim An_Array(128) As String lpBuffer = Space$(1024) ' 返回当前所有逻辑驱动器的根驱动器路径 GetLogicalDriveStrings Len(lpBuffer), lpBuffer j = InStr(lpBuffer, Chr$(0)) ' 存储磁盘驱动器的名称到An_Array中 Do While j > 0 An_Array(i) = Left$(lpBuffer, j - 1) i = i + 1 lpBuffer = Mid$(lpBuffer, j + 1) j = InStr(lpBuffer, Chr$(0)) Loop ReDim Preserve An_Array(DriveCount) End Function ' 返回磁盘驱动器的类型
Public Function Types(Optional sDrive As String) As String Select Case GetDriveType(sDrive) Case DRIVE_UNKNOWN Types = "不能识别" Case DRIVE_NO_ROOT_DIR Types = "不存在" Case DRIVE_REMOVABLE Types = "可移除驱动器" Case DRIVE_FIXED Types = "固定驱动器" Case DRIVE_REMOTE Types = "远程驱动器" Case DRIVE_CDROM Types = "光盘驱动器" Case DRIVE_RAMDISK Types = "随机存取磁盘" Case Else Types = "ERROR" End Select End Function Private Sub Command1_Click()
Dim DrivesN() As String Dim i As Integer Me.Cls Print "驱动器个数:" & DriveCount Call LoadDrivenames(DrivesN) For i = 0 To DriveCount - 1 List1.AddItem DrivesN(i) & Types(DrivesN(i)) Next i End Sub ------------------------------------------------- ComboBox加长加宽下拉选单 'form code: Private Declare Function MoveWindow Lib "user32" _ (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long Const CB_SETDROPPEDWIDTH = &H160 ' 设置ComboBox下拉选单长度函数
Public Sub SetComboHeight(ComboBox_Obj As ComboBox, NewHeight As Long) Dim OldScaleMode As Integer If TypeOf ComboBox_Obj.Parent Is Frame Then Exit Sub ' 改变ComboBox控件的容器的坐标度量单位为象素 OldScaleMode = ComboBox_Obj.Parent.ScaleMode ComboBox_Obj.Parent.ScaleMode = vbPixels ' 重新定义ComboBox的尺寸 MoveWindow ComboBox_Obj.hwnd, ComboBox_Obj.Left, _ ComboBox_Obj.Top, ComboBox_Obj.Width, NewHeight, 1 ' 恢复ComboBox控件的容器的坐标度量单位 ComboBox_Obj.Parent.ScaleMode = OldScaleMode End Sub ' 设置ComboBox下拉选单宽度函数
Public Sub SetComboWidth(ComboBox_Obj As ComboBox, NewWidth As Long) ' NewWidth 是宽度，单位是 pixels SendMessage ComboBox_Obj.hwnd, CB_SETDROPPEDWIDTH, NewWidth, 0 End Sub Private Sub Form_Load()
Dim i As Integer ' 向ComboBox添加项 For i = 0 To 40 Combo1.AddItem ("This is the long Item " + CStr(i)) Next i End Sub ' 改变ComboBox下拉选单长度和宽度
Private Sub Change_But_Click() Call SetComboHeight(Combo1, 300) Call SetComboWidth(Combo1, 200) End Sub 获取硬盘序列号、生产厂家/型号
【Class Code:将下面代码用记事本保存为 CDiskInfo.cls(类模块文件),此括弧及括弧内容除外】 Option Explicit 'http://vip./NowCan1/tech/vb_hd_info.htm
'-------------------------------------------------------------------------- ' 类模块： CDiskInfo.cls ' 功能说明：获取硬盘序列号、生产厂家/型号 ' 注意事项：支持Windows 95 OSR2, Windows 98, Windows NT, Windows 2000 ' XP没有测试，估计没问题，在Win9X下必须保证存在SMARTVSD.vxd '-------------------------------------------------------------------------- Private Const MAX_IDE_DRIVES As Long = 4
Private Const READ_ATTRIBUTE_BUFFER_SIZE As Long = 512 Private Const IDENTIFY_BUFFER_SIZE As Long = 512 Private Const READ_THRESHOLD_BUFFER_SIZE As Long = 512 Private Const DFP_GET_VERSION As Long = &H74080 Private Const DFP_SEND_DRIVE_COMMAND As Long = &H7C084 Private Const DFP_RECEIVE_DRIVE_DATA As Long = &H7C088 Private Type GETVERSIONOUTPARAMS
bVersion As Byte bRevision As Byte bReserved As Byte bIDEDeviceMap As Byte fCapabilities As Long dwReserved(3) As Long End Type Private Const CAP_IDE_ID_FUNCTION As Long = 1
Private Const CAP_IDE_ATAPI_ID As Long = 2 Private Const CAP_IDE_EXECUTE_SMART_FUNCTION As Long = 4 Private Type IDEREGS
bFeaturesReg As Byte bSectorCountReg As Byte bSectorNumberReg As Byte bCylLowReg As Byte bCylHighReg As Byte bDriveHeadReg As Byte bCommandReg As Byte bReserved As Byte End Type Private Type SENDCMDINPARAMS
cBufferSize As Long irDriveRegs As IDEREGS bDriveNumber As Byte bReserved(2) As Byte dwReserved(3) As Long bBuffer(0) As Byte End Type Private Const IDE_ATAPI_ID As Long = &HA1
Private Const IDE_ID_FUNCTION As Long = &HEC Private Const IDE_EXECUTE_SMART_FUNCTION As Long = &HB0 Private Const SMART_CYL_LOW As Long = &H4F Private Const SMART_CYL_HI As Long = &HC2 Private Type DRIVERSTATUS
bDriverError As Byte bIDEStatus As Byte bReserved(1) As Byte dwReserved(1) As Long End Type Private Const SMART_NO_ERROR As Long = 0
Private Const SMART_IDE_ERROR As Long = 1 Private Const SMART_INVALID_FLAG As Long = 2 Private Const SMART_INVALID_COMMAND As Long = 3 Private Const SMART_INVALID_BUFFER As Long = 4 Private Const SMART_INVALID_DRIVE As Long = 5 Private Const SMART_INVALID_IOCTL As Long = 6 Private Const SMART_ERROR_NO_MEM As Long = 7 Private Const SMART_INVALID_REGISTER As Long = 8 Private Const SMART_NOT_SUPPORTED As Long = 9 Private Const SMART_NO_IDE_DEVICE As Long = 10 Private Type SENDCMDOUTPARAMS
cBufferSize As Long drvStatus As DRIVERSTATUS bBuffer(0) As Byte End Type Private Const SMART_READ_ATTRIBUTE_VALUES As Long = &HD0
Private Const SMART_READ_ATTRIBUTE_THRESHOLDS As Long = &HD1 Private Const SMART_ENABLE_DISABLE_ATTRIBUTE_AUTOSAVE As Long = &HD2 Private Const SMART_SAVE_ATTRIBUTE_VALUES As Long = &HD3 Private Const SMART_EXECUTE_OFFLINE_IMMEDIATE As Long = &HD4 Private Const SMART_ENABLE_SMART_OPERATIONS As Long = &HD8 Private Const SMART_DISABLE_SMART_OPERATIONS As Long = &HD9 Private Const SMART_RETURN_SMART_STATUS As Long = &HDA Private Type DRIVEATTRIBUTE
bAttrID As Byte wStatusFlags As Integer bAttrValue As Byte bWorstValue As Byte bRawValue(5) As Byte bReserved As Byte End Type Private Type ATTRTHRESHOLD
bAttrID As Byte bWarrantyThreshold As Byte bReserved(9) As Byte End Type Private Type IDSECTOR
wGenConfig As Integer wNumCyls As Integer wReserved As Integer wNumHeads As Integer wBytesPerTrack As Integer wBytesPerSector As Integer wSectorsPerTrack As Integer wVendorUnique(2) As Integer sSerialNumber(19) As Byte wBufferType As Integer wBufferSize As Integer wECCSize As Integer sFirmwareRev(7) As Byte sModelNumber(39) As Byte wMoreVendorUnique As Integer wDoubleWordIO As Integer wCapabilities As Integer wReserved1 As Integer wPIOTiming As Integer wDMATiming As Integer wBS As Integer wNumCurrentCyls As Integer wNumCurrentHeads As Integer wNumCurrentSectorsPerTrack As Integer ulCurrentSectorCapacity(3) As Byte wMultSectorStuff As Integer ulTotalAddressableSectors(3) As Byte wSingleWordDMA As Integer wMultiWordDMA As Integer bReserved(127) As Byte End Type Private Const ATTR_INVALID As Long = 0
Private Const ATTR_READ_ERROR_RATE As Long = 1 Private Const ATTR_THROUGHPUT_PERF As Long = 2 Private Const ATTR_SPIN_UP_TIME As Long = 3 Private Const ATTR_START_STOP_COUNT As Long = 4 Private Const ATTR_REALLOC_SECTOR_COUNT As Long = 5 Private Const ATTR_READ_CHANNEL_MARGIN As Long = 6 Private Const ATTR_SEEK_ERROR_RATE As Long = 7 Private Const ATTR_SEEK_TIME_PERF As Long = 8 Private Const ATTR_POWER_ON_HRS_COUNT As Long = 9 Private Const ATTR_SPIN_RETRY_COUNT As Long = 10 Private Const ATTR_CALIBRATION_RETRY_COUNT As Long = 11 Private Const ATTR_POWER_CYCLE_COUNT As Long = 12 Private Const PRE_FAILURE_WARRANTY As Long = &H1 Private Const ON_LINE_COLLECTION As Long = &H2 Private Const PERFORMANCE_ATTRIBUTE As Long = &H4 Private Const ERROR_RATE_ATTRIBUTE As Long = &H8 Private Const EVENT_COUNT_ATTRIBUTE As Long = &H10 Private Const SELF_PRESERVING_ATTRIBUTE As Long = &H20 Private Const NUM_ATTRIBUTE_STRUCTS As Long = 30 Private Const INVALID_HANDLE_VALUE As Long = -1 Private Const VER_PLATFORM_WIN32s As Long = 0 Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1 Private Const VER_PLATFORM_WIN32_NT As Long = 2 Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type (待续)
(续) Private Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" _ (lpVersionInformation As OSVERSIONINFO) As Long Private Const CREATE_NEW As Long = 1 Private Const GENERIC_READ As Long = &H80000000 Private Const GENERIC_WRITE As Long = &H40000000 Private Const FILE_SHARE_READ As Long = &H1 Private Const FILE_SHARE_WRITE As Long = &H2 Private Const OPEN_EXISTING As Long = 3 Private Declare Function CreateFile Lib "KERNEL32" Alias "CreateFileA" _ (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _ ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long) As Long Private Declare Function DeviceIoControl Lib "KERNEL32" _ (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, _ ByVal nInBufferSize As Long, lpOutBuffer As Any, _ ByVal nOutBufferSize As Long, lpBytesReturned As Long, _ ByVal lpOverlapped As Long) As Long Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _ (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function CloseHandle Lib "KERNEL32" _ (ByVal hObject As Long) As Long Private m_DiskInfo As IDSECTOR Private Function OpenSMART(ByVal nDrive As Byte) As Long
Dim hSMARTIOCTL As Long
Dim hd As String Dim VersionInfo As OSVERSIONINFO hSMARTIOCTL = INVALID_HANDLE_VALUE
VersionInfo.dwOSVersionInfoSize = Len(VersionInfo) GetVersionEx VersionInfo Select Case VersionInfo.dwPlatformId Case VER_PLATFORM_WIN32s OpenSMART = hSMARTIOCTL Case VER_PLATFORM_WIN32_WINDOWS 'Version Windows 95 OSR2, Windows 98 hSMARTIOCTL = CreateFile("\\.\SMARTVSD", 0, 0, 0, CREATE_NEW, 0, 0) Case VER_PLATFORM_WIN32_NT 'Windows NT, Windows 2000 If nDrive < MAX_IDE_DRIVES Then hd = "\\.\PhysicalDrive" & nDrive hSMARTIOCTL = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _ FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0) End If End Select OpenSMART = hSMARTIOCTL End Function
Private Function DoIDENTIFY(ByVal hSMARTIOCTL As Long, _
pSCIP As SENDCMDINPARAMS, pSCOP() As Byte, ByVal bIDCmd As Byte, _ ByVal bDriveNum As Byte, lpcbBytesReturned As Long) As Boolean '------------------------------------------------------------------- pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE pSCIP.irDriveRegs.bFeaturesReg = 0
pSCIP.irDriveRegs.bSectorCountReg = 1 pSCIP.irDriveRegs.bSectorNumberReg = 1 pSCIP.irDriveRegs.bCylLowReg = 0 pSCIP.irDriveRegs.bCylHighReg = 0 pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) * 2 ^ 4)
pSCIP.irDriveRegs.bCommandReg = bIDCmd
pSCIP.bDriveNumber = bDriveNum pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE DoIDENTIFY = CBool(DeviceIoControl(hSMARTIOCTL, DFP_RECEIVE_DRIVE_DATA, _ pSCIP, 32, pSCOP(0), 528, lpcbBytesReturned, 0)) End Function
Private Function DoEnableSMART(ByVal hSMARTIOCTL As Long, _
pSCIP As SENDCMDINPARAMS, pSCOP As SENDCMDOUTPARAMS, _ ByVal bDriveNum As Byte, lpcbBytesReturned As Long) As Boolean '--------------------------------------------------------------------- pSCIP.cBufferSize = 0 pSCIP.irDriveRegs.bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS pSCIP.irDriveRegs.bSectorCountReg = 1 pSCIP.irDriveRegs.bSectorNumberReg = 1 pSCIP.irDriveRegs.bCylLowReg = SMART_CYL_LOW pSCIP.irDriveRegs.bCylHighReg = SMART_CYL_HI pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) * 2 ^ 4) pSCIP.irDriveRegs.bCommandReg = IDE_EXECUTE_SMART_FUNCTION pSCIP.bDriveNumber = bDriveNum DoEnableSMART = CBool(DeviceIoControl(hSMARTIOCTL, DFP_SEND_DRIVE_COMMAND, _
pSCIP, LenB(pSCIP) - 1, pSCOP, LenB(pSCOP) - 1, lpcbBytesReturned, 0)) End Function
Private Sub ChangeByteOrder(szString() As Byte, ByVal uscStrSize As Integer)
Dim i As Integer Dim bTemp As Byte For i = 0 To uscStrSize - 1 Step 2
bTemp = szString(i) szString(i) = szString(i + 1) szString(i + 1) = bTemp Next i End Sub Private Sub DisplayIdInfo(pids As IDSECTOR, pSCIP As SENDCMDINPARAMS, _
ByVal bIDCmd As Byte, ByVal bDfpDriveMap As Byte, ByVal bDriveNum As Byte) '-------------------------------------------------------------------------- ChangeByteOrder pids.sModelNumber, UBound(pids.sModelNumber) + 1 'ChangeByteOrder pids.sFirmwareRev, UBound(pids.sFirmwareRev) + 1 ChangeByteOrder pids.sSerialNumber, UBound(pids.sSerialNumber) + 1 End Sub '调用过程
Public Function GetDiskInfo(ByVal nDrive As Byte) As Long Dim hSMARTIOCTL As Long Dim cbBytesReturned As Long Dim VersionParams As GETVERSIONOUTPARAMS Dim scip As SENDCMDINPARAMS Dim scop() As Byte Dim OutCmd As SENDCMDOUTPARAMS Dim bDfpDriveMap As Byte Dim bIDCmd As Byte Dim uDisk As IDSECTOR m_DiskInfo = uDisk
hSMARTIOCTL = OpenSMART(nDrive) If hSMARTIOCTL <> INVALID_HANDLE_VALUE Then Call DeviceIoControl(hSMARTIOCTL, DFP_GET_VERSION, ByVal 0, 0, _ VersionParams, Len(VersionParams), cbBytesReturned, 0) If Not (VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10) Then
If DoEnableSMART(hSMARTIOCTL, scip, OutCmd, nDrive, cbBytesReturned) Then bDfpDriveMap = bDfpDriveMap Or 2 ^ nDrive End If End If bIDCmd = IIf((VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10), _ IDE_ATAPI_ID, IDE_ID_FUNCTION) ReDim scop(LenB(OutCmd) + IDENTIFY_BUFFER_SIZE - 1) As Byte
If DoIDENTIFY(hSMARTIOCTL, scip, scop, bIDCmd, nDrive, cbBytesReturned) Then CopyMemory m_DiskInfo, scop(LenB(OutCmd) - 4), LenB(m_DiskInfo) Call DisplayIdInfo(m_DiskInfo, scip, bIDCmd, bDfpDriveMap, nDrive) CloseHandle hSMARTIOCTL GetDiskInfo = 1 Exit Function End If CloseHandle hSMARTIOCTL GetDiskInfo = 0 Else GetDiskInfo = -1 End If End Function '硬盘生产厂/型号 Public Property Get pSerialNumber() As String pSerialNumber = StrConv(m_DiskInfo.sSerialNumber, vbUnicode) pSerialNumber = PurString(pSerialNumber) End Property '硬盘序列号
Public Property Get pModelNumber() As String pModelNumber = StrConv(m_DiskInfo.sModelNumber, vbUnicode) pModelNumber = PurString(pModelNumber) End Property Private Function PurString(str As String) As String
'On Error Resume Next Dim i As Integer For i = 1 To Len(str) If Asc(Mid(str, i, 1)) <> 0 Then PurString = PurString & Mid(str, i, 1) Next PurString = Trim(PurString) End Function '################################################################################
'窗体代码： 'Private Sub Form_Load() ' Dim hdinfo As New CDiskInfo ' hdinfo.GetDiskInfo 0 ' Text1.Text = "生产厂家/型号:" & hdinfo.pModelNumber ' Text2.Text = "硬盘序列号:" & hdinfo.pSerialNumber 'End Sub 设置显示模式 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 3540 ClientLeft = 60 ClientTop = 345 ClientWidth = 5970 LinkTopic = "Form1" ScaleHeight = 3540 ScaleWidth = 5970 StartUpPosition = 3 '窗口缺省 Begin VB.ListBox List1 Height = 3300 Left = 120 TabIndex = 2 Top = 120 Width = 4215 End Begin VB.CommandButton Command2 Caption = "退出" Height = 375 Left = 4560 TabIndex = 1 Top = 1080 Width = 1335 End Begin VB.CommandButton Command1 Caption = "设置显示模式" Height = 375 Left = 4560 TabIndex = 0 Top = 360 Width = 1335 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwflags As Long) As Long Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _ (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long Private Declare Function SendMessageByLong& Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) Private Declare Function InvalidateRect Lib "user32" _ (ByVal hwnd As Long, lprect As Any, ByVal bErase As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Type RECT
Left As Long Top As Long Right As Long Bottom As Long End Type ' 设备模式结构
Private Type DEVMODE dmDeviceName As String * 32 dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName(1 To 32) As Byte dmLogPixels As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long dmICMMethod As Long ' Windows 95 only dmICMIntent As Long ' Windows 95 only dmMediaType As Long ' Windows 95 only dmDitherType As Long ' Windows 95 only dmReserved1 As Long ' Windows 95 only dmReserved2 As Long ' Windows 95 only End Type Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Const DM_DISPLAYFLAGS = &H200000 Const DM_DISPLAYFREQUENCY = &H400000 Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1 Const DISP_CHANGE_FAILED = -1 Const DISP_CHANGE_BADMODE = -2 Const DISP_CHANGE_NOTUPDATED = -3 Const DISP_CHANGE_BADFLAGS = -4 Const DISP_CHANGE_BADPARAM = -5 Const CDS_UPDATEREGISTRY = 1
Const CDS_FORCE As Long = &H80000000 Const CDS_RESET = &H40000000 Const HWND_BROADCAST = &HFFFF&
Const WM_SYSCOLORCHANGE = &H15 Const WM_PALETTECHANGED = &H311 Const WM_DISPLAYCHANGE = &H7E Const WM_SETTINGCHANGE = &H1A Dim ModeCube(128) As DEVMODE
Dim lproc As Long ' 列出显示设备支持的显示模式
Sub LoadDisplayMode() Dim i As Long Dim RS As Long Dim AStr As String i = 0 ' 遍历所有的显示模式并在List1中显示出来 Do ModeCube(i).dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_DISPLAYFLAGS Or DM_DISPLAYFREQUENCY
ModeCube(i).dmSize = Len(ModeCube(i)) '获得显示模式并保存到数组中 RS = EnumDisplaySettings(vbNullString, i, ModeCube(i)) If RS Then AStr = Str$(ModeCube(i).dmPelsWidth) + "*" + Trim$(Str$(ModeCube(i).dmPelsHeight)) + " " Select Case ModeCube(i).dmBitsPerPel Case 4 AStr = AStr + "16色" Case 8 AStr = AStr + "256色" Case 16 AStr = AStr + "16位彩色" Case 24 AStr = AStr + "24位彩色" Case 32 AStr = AStr + "32位彩色" Case Else AStr = AStr + Str$(ModeCube(i).dmBitsPerPel) End Select AStr = AStr + " 刷新频率:" & CStr(ModeCube(i).dmDisplayFrequency) + "Hz" i = i + 1 End If List1.AddItem AStr Loop Until (RS = 0) '获得最后一个显示模式之后EnumDisplaySettings会返回0 End Sub ' 设置显示模式
Private Sub Command1_Click() Dim aDev As DEVMODE Dim RS As Long If List1.ListIndex < 0 Then Exit Sub aDev = ModeCube(List1.ListIndex) RS = ChangeDisplaySettings(aDev, CDS_FORCE) ' 改变完显示模式设置之后向所有的窗口发送显示模式改变消息 RS = SendMessageByLong(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&) RS = SendMessageByLong(HWND_BROADCAST, WM_PALETTECHANGED, Me.hwnd, 0&) RS = PostMessage(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&) ' windows就会重画窗口 RS = InvalidateRect(0&, ByVal 0, 1&) End Sub ' 加载窗体时加载显示系统支持的显示模式
Private Sub Form_Load() LoadDisplayMode End Sub ------------------------------------------ 使ComboBox自动下拉 Option Explicit
'使ComboBox自动下拉
Const CB_SHOWDROPDOWN = &H14F 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 Sub Combo1_Click()
Text1.Text = Combo1.Text End Sub Private Sub Combo1_GotFocus()
'获得焦点自动拉开 SendMessage Combo1.hWnd, CB_SHOWDROPDOWN, 1, ByVal 0& End Sub Private Sub Form_Load()
Dim i As Integer For i = 0 To 10 Combo1.AddItem "项目" & i Next End Sub -------------------------------------------------------
动态添加控件
Option Explicit
Private WithEvents NewButton As CommandButton
Private Sub Command1_Click()
If NewButton Is Nothing Then Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me) NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top NewButton.Caption = "新按钮" NewButton.Visible = True End If End Sub Private Sub NewButton_Click()
MsgBox "你单击了" & NewButton.Caption End Sub ----------------------------------------------------- '取得控件绝对Top值(left值也类似) Public Function AbsoluteTop(ctlContl As Control) As Single Dim wrkContl As Control Dim wrkTopPos As Single ' On Error GoTo AbsoluteTopError ' 初始 Set wrkContl = ctlContl wrkTopPos = 0 ' 循环 Do If (wrkContl.Container.Name = ctlContl.Parent.Name) Then Exit Do wrkTopPos = wrkTopPos + wrkContl.Top ' 计算位置 Set wrkContl = wrkContl.Container ' 下个控件 Loop AbsoluteTop = wrkTopPos + ctlContl.Parent.Top Exit Function ' AbsoluteTopError: AbsoluteTop = ctlContl.Top + ctlContl.Parent.Top End Function SendMessage函数
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 5700 ClientLeft = 60 ClientTop = 450 ClientWidth = 6735 LinkTopic = "Form1" ScaleHeight = 5700 ScaleWidth = 6735 StartUpPosition = 3 '窗口缺省 Begin VB.TextBox Text2 Height = 375 Left = 1320 TabIndex = 14 Top = 2880 Width = 1215 End Begin VB.ListBox List1 Height = 1860 Left = 1320 TabIndex = 13 Top = 3360 Width = 1215 End Begin VB.CommandButton Command4 Caption = "添加项目和滚动条" Height = 495 Left = 3120 TabIndex = 11 Top = 3480 Width = 1935 End Begin VB.CommandButton Command3 Caption = "收起" Height = 495 Left = 4320 TabIndex = 10 Top = 2040 Width = 1215 End Begin VB.CommandButton Command2 Caption = "拉开" Height = 495 Left = 3000 TabIndex = 9 Top = 2040 Width = 1215 End Begin VB.ComboBox Combo1 Height = 300 Left = 960 TabIndex = 8 Text = "Combo1" Top = 2040 Width = 1935 End Begin VB.CommandButton Command1 Caption = "统计" Height = 495 Left = 5040 TabIndex = 6 Top = 240 Width = 1215 End Begin VB.TextBox TxtString Height = 495 Left = 2880 TabIndex = 2 Top = 960 Width = 1815 End Begin VB.TextBox txtLineCount Height = 375 Left = 3600 TabIndex = 1 Top = 120 Width = 1095 End Begin VB.TextBox Text1 Height = 1335 Left = 960 MultiLine = -1 'True TabIndex = 0 Top = 120 Width = 1575 End Begin VB.Label Label4 Caption = "例三 例四" Height = 255 Index = 1 Left = 120 TabIndex = 12 Top = 2880 Width = 1095 End Begin VB.Label Label4 Caption = "例二" Height = 255 Index = 0 Left = 120 TabIndex = 7 Top = 2040 Width = 735 End Begin VB.Label Label3 Caption = "例一" Height = 255 Left = 120 TabIndex = 5 Top = 120 Width = 495 End Begin VB.Label Label2 Caption = "第三行字符:" Height = 255 Left = 2880 TabIndex = 4 Top = 720 Width = 1215 End Begin VB.Label Label1 Caption = "总行数:" Height = 255 Left = 2880 TabIndex = 3 Top = 240 Width = 735 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False 'SendMessage函数在VB中的函数说明如下: '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 '其中四个自变量的含义和说明如下: 'hWnd：对象的句柄。希望将消息传送给哪个对象，就把该对象的句柄作为实参传送， '在VB中可以简单地用“对象.hWnd”获得某个对象的句柄， '如Text1.hWnd和Form1.hWnd分别可以得到Text1和Form1的句柄。 'wMsg：被发送的消息。根据具体需求和不同的对象，将不同的消息作为实参传送，以产生预期的动作。 'wParam、lParam：附加的消息信息。这两个是可选的参数，用来提供关于wMsg消息更多的信息， '不同的wMsg可能使用这两个参数中的0、1或2个，如果不需要哪个附加参数，则将实参赋为NULL（在VB中赋为0）。 '例1 多行TextBox中的快速处理功能在处理多行TextBox时我们经常会碰到以下几种情况: '希望了解多行TextBox中目前共有多少行文字? '想快速返回第N行的文字? '对于上面的情况，如果用VB自身的语句或函数来实现的话，要写不短的代码， '而且由于要采用顺序查找的办法来完成，因此代码的执行效率也很低。 '如果使用SendMessage函数则可以大大减少代码量，并大幅度的提高执行效率。 '用SendMessage函数完成上面两个任务的方法非常简单，每个任务只需简单地发送一条消息给多行TextBox即可， '两个消息分别为：EM_GETLINECOUNT、EM_GETLINE，其它参数和返回值见附表。 '新建工程，在Form1上添加三个TextBox（名称分别为Text1、txtLineCount、TxtString， '将Text1的MultiLine属性置为True）、三个标签和一个命令按钮。 '为工程添加一个模块Moudle1，在其中写如下声明（其中 'SendMessage函数的声明可以从VB的“API浏览器”中复制）： 消息常量名 消息值 wParam lParam 返回值 'EM_GETLINECOUNT &HBA 未用 未用 行数 'EM_GETLINE &HC4 要找的行号 存结果的字节串 结果字节串的字节数 '两点补充说明：在调用SendMessage获取第N行字符串时，lParam需要说明为字节数组，
'在调用完成后，再将字节数组转换为字符串； '另外，调用前必须在lParam的前两个字节指明允许存放的最大长度， '其中第一个字节为低位，第二个字节为高位，本例将高位（即str(1)）置1．说明最大允许存放256个字符。 Private Sub Command1_Click()
Dim str(256) As Byte str(1) = 1 '最大允许存放256个字符 '获取总行数，结果显示在文本框txtLineCount中 txtLineCount = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0) '获取第3行的数据放在str中，转换为字符串后显示在文本框txtString中 SendMessage Text1.hwnd, EM_GETLINE, 2, str(0) TxtString = StrConv(str, vbUnicode) End Sub '例2 程序控制拉下或收起组合框的下拉列来
'一般情况下，为了拉下或收起组合框的下拉列表，需要用键盘或鼠标进行操作， '而有时我们希望程序运行的某个时刻自动拉出下拉列表（比如在一些演示程序中）， '为了实现这个目的，我们也只有借助于SendMessage函数，方法是发一个CB_SHOWDROPDOWN(&H14F)消息给组合框。 '在发CB_SHOWDROPDOWN消息时，wParam参数决定了是拉下列表（=True时）还是收起列表（＝False时）， 'lParam无用（设为0）。 Private Sub Form_Load() Dim i As Integer For i = 0 To 10 Combo1.AddItem "项目" & i Next End Sub Private Sub Command2_Click()
'当程序中某处需要拉下组合框Combol的列表时，写如下调用语句： SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, True, str(0) End Sub Private Sub Command3_Click()
'当需要收起组合框Combol的列表时，写如下语句： SendMessage Combol.hwnd, CB_SHOWDROPDOWN, False, str(0) End Sub '例3 在列表框中查找匹配的项目 '在Win95风格的帮助系统中一般都有一个“索引”页，索引页含有一个文本框和一个列表框， '当用户在文本框中输入文字时，下拉列表会动态地显示与文本框中文字最匹配的项目， '为用户提供了最大的方便。 '这种效果在应用程序的帮助系统中很容易实现（只要按照Win95帮助系统的正常制作过程制作就可以实现）， '如果想在应用程序的其它地方实现这种特性就需费一番心思了。 '而使用SendMessage函数实现上述特性则非常简单，甚至只需一条语句就足够了， '那就是在文本框的Change事件中给列表框发一条LB_FINDSTRING(&H18F）消息， '该消息告诉列表框在列表中查找匹配的项目。 '在发LB_FINDSTRING消息时，wParam参数代表从列表框的哪一个项目后面开始查找， '一般情况下该参数可定为-1，表示从List1(0)即第一项开始向后循环查找， 'lParam则传进欲搜索的字符串（必须采用值传递）。 '具体的代码和运行画面与后面的例4合并在一起演示 '例4 为ListBox添加水平滚动条 '在VB中，列表框控件仅提供垂直滚动条，没有设置水平滚动条的能力，当某些项目的文本宽度较长时， '超出列表框宽度部分的文本就无法显示出来，因此，很有必要为ListBox添加一个水平滚动条来方便操作。 '为添加水平滚动条，只需发一条LB_SETHORIZONTALEXTENT(&H194)消息给列表框即可。 '发送消息时，wParam为滚动条的长度（以像素为单位，可通过计算得出准确的长度， '也可随便给一个大于最大文本宽度的数字，如本例的250），lParam无用。 '下面是例3和例4合并在一起的代码和运行画面 Private Sub Command4_Click() List1.AddItem "软件" List1.AddItem "电脑游戏" List1.AddItem "电视机" List1.AddItem "电视台" List1.AddItem "电脑" List1.AddItem "电脑游戏软件" '下一句为列表框添加水平滚动条 SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, 250, 0 End Sub Private Sub Text2_Change()
'注意！当lParam传入的是字符串时，必须用ByVal传递 List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal Text2.Text) End Sub '事实上利用该函数我们还可以完成更多更好的任务，
'如控制文本框的自动滚屏、实现文字编辑过程中的Undo功能、操纵应用程序的窗体控制菜单等等 【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】
Attribute VB_Name = "Module1" '例1 Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const EM_GETLINECOUNT = &HBA Public Const EM_GETLINE = &HC4 '例2
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const CB_SHOWDROPDOWN = &H14F '例3 例4
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const LB_FINDSTRING = &H18F Public Const LB_SETHORIZONTALEXTENT = &H194 使窗口不接受键盘输入及Mouse Click
'就好比呼叫MsgBox之後，Form就不接受Mouse Click与KeyPress，但是Form仍可处於Activate的状态， '即我们暂停了Mouse Click,KeyPress，等待我们要做事都做完了，再将之回复。 '不过Mouse仍可自由的移动，若要让Mouse也不能动，就使用JournalPlayBack Hook，而不是使用本方法。 'EnableWindow()可达目的，第二个参数传0进入则不能输入，传1则相反
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Command1_Click()
'封闭 Call EnableWindow(Me.hwnd, 0) Me.Caption = "现在拒绝KeyPress, MouseClick" '限时后解开 Dim i As Long For i = 1 To 100 Call Sleep(100) DoEvents '虽有DoEvents，会发现，按Form的任何地方都没有反应 Next i Me.Caption = "现在解除了" Call EnableWindow(Me.hwnd, 1) End Sub ---------------------------------------------------
半透明窗体
Option Explicit
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 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 Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2 Private Sub Command1_Click()
'关闭 Timer4.Interval = 50 End Sub Private Sub Form_Load()
Dim FormStyle As Long '取的窗口原先的样式 FormStyle = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '使窗体添加上新的样式WS_EX_LAYERED FormStyle = FormStyle Or WS_EX_LAYERED '把新的样式赋给窗体 SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED '直接设置一个值(0-255之间)替换数值255来改变透明度,这里用180 SetLayeredWindowAttributes Me.hwnd, 0, 180, LWA_ALPHA End Sub ------------------------------------------------------------
去掉关闭按钮 - 例子
'Module Code:
Option Explicit '第一种方法 Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Declare Function DeleteMenu Lib "User32" _ (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long Public Const MF_BYPOSITION = &H400& '第二种方法
'Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Declare Function RemoveMenu Lib "User32" _ (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long 'Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long 'Public Const MF_BYPOSITION = &H400& Public Const MF_DISABLED = &H2& '第一种方法
Public Sub DisableX(Frm As Form) Dim hMenu As Long, nCount As Long hMenu = GetSystemMenu(Frm.hwnd, 0) nCount = GetMenuItemCount(hMenu) Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION) DrawMenuBar Frm.hwnd End Sub 'Form Code: Option Explicit 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 '第二种方法 'Call DisableX(Me) End Sub Private Sub Command1_Click()
End End Sub ----------------------------------------------------------
运行时改变BorderStyle属性值
Option Explicit
Private Const GWL_STYLE As Long = (-16&)
Private Const GWL_EXSTYLE As Long = (-20&) Private Const WS_THICKFRAME As Long = &H40000 Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hWnd&, ByVal nIndex&)
Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&) Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI) Private Declare Function SetCursorPos& Lib "user32" (ByVal x&, ByVal y&) Private Declare Function ClientToScreen& Lib "user32" (ByVal hWnd&, lpPoint As POINTAPI) Private Declare Function GetSystemMenu& Lib "user32" (ByVal hWnd&, ByVal bRevert&) Private Sub Command1_Click()
Call SetWindowLong(hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) Xor _ (WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)) Call GetSystemMenu(hWnd, 1&) Move Left, Top, Width - 50, Height - 50 Move Left, Top, Width + 50, Height + 50 Dim tagSavePoint As POINTAPI, tagMovePoint As POINTAPI Call GetCursorPos(tagSavePoint) With tagMovePoint .x = (-1) .y = 10 End With Call ClientToScreen(hWnd, tagMovePoint) Call SetCursorPos(tagMovePoint.x, tagMovePoint.y) Call SetCursorPos(tagSavePoint.x, tagSavePoint.y) End Sub -------------------------------------------------------------------------- 最小化所有窗口 'Module Code:
Option Explicit Public Declare Function EnumWindows Lib "user32" _
(ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function ShowWindow Lib "user32" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Public Const WS_MINIMIZEBOX = &H20000 Public Const WS_VISIBLE = &H10000000 Public Const GWL_STYLE = (-16) Public Const SW_MINIMIZE = 6 '该函数是EnumWindows的回调函数，EnumWindows函数将遍历的窗口句柄传递到hwnd参数中 Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long Dim l As Long Dim ld As Long ld = GetWindowLong(hwnd, GWL_STYLE) '如果窗口具有最小化按钮并且窗口是可见的就将该窗口最小化 If ((ld And WS_MINIMIZEBOX) = WS_MINIMIZEBOX) Then If ((ld And WS_VISIBLE)) Then If ShowWindow(hwnd, SW_MINIMIZE) Then End If End If End If EnumWindowsProc = True End Function 'form code Private Sub Command1_Click() Dim l As Long '遍历所有的窗口 l = EnumWindows(AddressOf EnumWindowsProc, 0) End Sub ------------------------------------------------------------------------ 动态光标 Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
(ByVal lpFileName As String) As Long Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Const GCL_HCURSOR = (-12)
Dim mhBaseCursor As Long Dim mhAniCursor As Long Private Sub Form_Load()
'保存缺省的光标 mhBaseCursor = GetClassLong(Me.hwnd, GCL_HCURSOR) '装载动态光标文件 mhAniCursor = LoadCursorFromFile("horse.ani") '设置窗体光标为动态光标 SetClassLong Me.hwnd, GCL_HCURSOR, mhAniCursor End Sub '恢复缺省光标，并删除动画光标
Private Sub Form_Unload(Cancel As Integer) SetClassLong Me.hwnd, GCL_HCURSOR, mhBaseCursor DestroyCursor (mhAniCursor) End Sub 指挥光标移动和按键
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】
VERSION 5.00 Begin VB.Form FrmMouse Caption = "鼠标控制" ClientHeight = 3690 ClientLeft = 645 ClientTop = 2700 ClientWidth = 4095 HasDC = 0 'False KeyPreview = -1 'True LinkTopic = "Form1" ScaleHeight = 3690 ScaleWidth = 4095 Begin VB.CommandButton TestCmd Caption = "TestCmd" Height = 375 Left = 840 TabIndex = 2 Top = 240 Width = 1215 End Begin VB.CommandButton DemoCmd Caption = "演示" Height = 420 Left = 2280 TabIndex = 0 Top = 3240 Width = 1740 End Begin VB.Shape cmdDemo Height = 3075 Left = 75 Top = 45 Width = 3915 End Begin VB.Label lblTip AutoSize = -1 'True Caption = "提示" Height = 180 Left = 225 TabIndex = 1 Top = 3330 Width = 480 End End Attribute VB_Name = "FrmMouse" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const MK_CONTROL = &H8 ' 键盘Ctrl键
Private Const MK_LBUTTON = &H1 ' 鼠标左键 Private Const MK_MBUTTON = &H10 ' 鼠标中键 Private Const MK_RBUTTON = &H2 ' 鼠标右键 Private Const WM_MBUTTONDOWN = &H207 ' 鼠标中键按下
Private Const WM_MBUTTONUP = &H208 ' 鼠标中键抬起 Private Const WM_LBUTTONDOWN = &H201 ' 鼠标左键按下 Private Const WM_LBUTTONUP = &H202 ' 鼠标左键抬起 Private Const WM_LBUTTONDBLCLK = &H203 ' 鼠标左键双击 Private Const WM_MOUSEMOVE = &H200 ' 鼠标移动 Private Const WM_RBUTTONDBLCLK = &H206 ' 鼠标右键双击 Private Const WM_RBUTTONDOWN = &H204 ' 鼠标右键按下 Private Const WM_RBUTTONUP = &H205 ' 鼠标右键抬起 Private Const HWND_BROADCAST = &HFFFF& ' 用来对所有的窗口传送消息 Private Type POINTAPI
X As Long Y As Long End Type ' 根据lParam 参数取得对应的X,Y坐标
Private Function GetPointXY(ByVal lParam As Long) As POINTAPI GetPointXY.X = lParam And &HFFFF GetPointXY.Y = (lParam And &HFFFF0000) / (2 ^ 16) End Function ' 将位置坐标转换为 Twips单位
Private Function XY2Twips(ByRef pos As POINTAPI) pos.X = pos.X * Screen.TwipsPerPixelX pos.Y = pos.Y * Screen.TwipsPerPixelY End Function ' 移动光标
Private Sub MoveCursor(ByVal X As Integer, ByVal Y As Integer) SetCursorPos X, Y Me.Caption = "X:" & X & ",Y:" & Y End Sub ' 延时
Public Sub Pause(HowLong As Long) Dim tick As Long tick = GetTickCount() Do DoEvents Loop Until tick + HowLong < GetTickCount End Sub ' 移动光标
Private Sub MouseMove() Dim X As Long, Y As Long Dim pos As POINTAPI Dim demopos As POINTAPI ' 演示按钮区域的左上角 demopos.X = (TestCmd.Left + TestCmd.Width / 2 + Me.Left) / Screen.TwipsPerPixelX demopos.Y = (TestCmd.Top + TestCmd.Height / 2 + Me.Top + 300) / Screen.TwipsPerPixelY ' 得到当前光标位置 GetCursorPos pos ' 循环，将光标移动到 demopos 位置 For X = pos.X To demopos.X Step -1 Pause 4 MoveCursor X, pos.Y Next For Y = pos.Y To demopos.Y Step -1 Pause 10 MoveCursor demopos.X, Y Next End Sub ' 单击演示按钮开始演示
Private Sub DemoCmd_Click() Dim lParam As Long Dim pos As POINTAPI Dim i As Integer Dim h As Long ' 移动光标 Call MouseMove ' 得到当前光标位置 GetCursorPos pos lParam = CLng(pos.X) + CLng(pos.Y) * (2 ^ 16) h = TestCmd.hwnd ' 传递鼠标按下操作 Call PostMessage(h, WM_LBUTTONDOWN, MK_LBUTTON, lParam) lblTip.Caption = "光标按下" DoEvents ' 延时 Pause 1000 ' 传递鼠标抬起操作 Call PostMessage(Me.TestCmd.hwnd, WM_LBUTTONUP, MK_LBUTTON, lParam) Me.lblTip.Caption = "光标抬起" End Sub Private Sub TestCmd_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) MsgBox "HELLO" End Sub 关机消息的拦截
'模块代码
Option Explicit Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long 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 Const GWL_WNDPROC = (-4) Public Const WM_ENDSESSION = &H16 Public Const WM_QUERYENDSESSION = &H11 Public preWinProc As Long Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = WM_QUERYENDSESSION Then Debug.Print "QryEnd", wParam, lParam Else If Msg = WM_ENDSESSION Then If wParam = 0 Then '代表将顺利关机或LogOff，这时便得做正常结束程序的操作 '实际下面这些代码不会被执行,为了测试结果,先写上 Open "c:\ttt.txt" For Output As #1 Print #1, "正常关闭程序" & vbCrLf Close #1 Else 'wParam = 1 Open "c:\ttt.txt" For Output As #1 Print #1, "非正常关闭程序. wParam = " & wParam & vbCrLf & "关机时间:" & Now & vbCrLf Close #1 End If End If End If '将之送往原来的Window Procedure wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam) End Function '关机消息的拦截 '在关机或Logff前信息的拦截
'如果我们关机或Logoff时，我们的程序有时会因而无法按正常程序结束，一般我们会在Form的Unload中一段程序结束时
'要做什么事，但是，如果使用者直接用开始功能菜单的关机，会使UnLoad的部份没有做到， '我们现在就想办法来拦截关机(或Logoff)时的信息? '一般来说，关机或Logff后，Windows会传依序送出WM_QUERYENDSESSION的信息给每个Process，
'如果中间有一个Process不能顺利结束(例如：Word修改后未存档，而出现是否存档，但我们按取消)， '这时该信息执行的结果会传回False(0)，这时Windows也就不再继续送WM_QUERYENDSESSION给下一个Proccess。 '反之，如果所有的Process都可以顺利结束(也就是每个送出的WM_QUERYENDSESSION都传回True)， '那才代表可以顺利结束。 '不管WM_QUERYENDSESSION最后的结果是可以顺利结束或不能顺利结束，
'Windows会再送一个WM_ENDSESSION的信息给所有的Process， '而wParam的内容便是指出是否可以顺利结束(True菜单可以，False菜单不行， '在vb中则Check wParam = 0 菜单False，1菜单True)，说到这里大概就知道该如何做啦，程序如下： '窗体代码
Private Sub Form_Load() Dim ret As Long '记录原来的Window Procedure的位址 preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC) '设定form的window Procedure到wndproc ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End Sub Private Sub Form_Unload(Cancel As Integer) Dim ret As Long Dim fno As Long '取消Message的截取，而使之又只送往原来的Window Procedure ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc) '这里只是要看看用关机的方式结束程序时，会不会执行到这里 '退出程序时,会建立这个文件,并写入一段内容 fno = FreeFile Open "c:\tt2.txt" For Append As fno Print #fno, "ccc1" & vbCrLf & Now Close #fno End Sub ------------------------------------------------ '利用API实现清除文档名 '范例
'其中uFlags如为1,pv则为一路径字符串的地址;如为2,则为项标示列表的地址。 Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String) Private Sub Command1_Click()
Call SHAddToRecentDocs(2, vbNullString) End Sub '如果程序设计需要往"文档"菜单中添加文件,只需把vbNullString改为文件的路径,如“c:\windows\a.txt"
vb实现多线程！ S.F.（原作） 昨晚2:30的时候还没睡着，觉得有必要把vb编写多线程程序再次写一次；主要是以前忽略 的细节和重要的环节；今天在公司打开一年多没用的vb，写了如下的代码；想写多线程 的朋友可以调试一下看看，关于多线程的任务模式，同步和互斥，临界资源和临界区 （文中提到）欢迎跟帖讨论； '请将该部分数据保存为 FORM1.frm 文件 VERSION 5.00 Begin VB.Form Form1 Caption = "多线程" ClientHeight = 3195 ClientLeft = 60 ClientTop = 345 ClientWidth = 6450 LinkTopic = "Form1" ScaleHeight = 3195 ScaleWidth = 6450 StartUpPosition = 3 '窗口缺省 Begin VB.TextBox Text1 Height = 270 Left = 960 TabIndex = 2 Text = "2" Top = 2760 Width = 2415 End Begin VB.CommandButton Command2 Caption = "返回" Height = 255 Left = 3480 TabIndex = 1 Top = 2760 Width = 1455 End Begin VB.CommandButton Command1 Caption = "Start Count" Height = 255 Left = 3480 TabIndex = 0 Top = 240 Width = 1455 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "主线程执行结果测试:" Height = 180 Left = 600 TabIndex = 3 Top = 2400 Width = 1710 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '下载地址:http://www./vbThread.rar
Private Sub Command1_Click()
'声明了线程ID Dim threadid1 As Long Dim threadid2 As Long '参数一，lpThreadAttributes 线程安全属性，传递为NULL
'参数二，dwStackSize ，线程堆栈大小，可以为0，表示堆栈和此应用堆栈相同 '参数三，lpstartAddress ，执行函数地址，用AddressOf 获取 '参数四，lpParameter ，执行函数的参数地址，可以是一个记录或者是别的类型，用VarPtr获取参数地址（varptr为未公开函数）！！ '参数五，dwCreationFlags ，表示线程创建后的状态！，0表示立即运行，create_SUSPENDED表示线程挂起 '参数六，lpThreadID 表示分配给线程的线程号 Call CreateThread(Null, ByVal O&, AddressOf Module1.OutText1, VarPtr(0), ByVal 0&, threadid1) Call CreateThread(Null, ByVal 0&, AddressOf Module1.OutText2, VarPtr(0), ByVal 0&, threadid2) End Sub Private Sub Command2_Click()
'该事件运行于主线程！ Dim i As Long i = CLng(Text1.Text) Text1.Text = CStr(i * i) '不要点击次数太多，LONG 类型会溢出 End Sub Private Sub Form_Load()
'保存窗体句柄全局变量，用于在form 上绘图 formhandle = Form1.hwnd End Sub '请将该部分数据保存为 Module1.bas 文件 Attribute VB_Name = "Module1" '线程安全属性数据结构；
Public Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type '这个是用于多线程访问临界资源同步Api的数据结构
Public Type CRITICAL_SECTION dummy As Long End Type '为什么用GDI 函数绘图？原因等下再讲 Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long '请注意；createThread APi声明已被我修改过，修改的地方请自行参照APIView复制的内容 Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long '这个是sleep,作用就是让两个线程绘图频率不一致，效果才明显。 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Sub EnterCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION) '进入临界区 Public Declare Sub LeaveCriticalSection Lib "kernel32" (lpCriticalSection As CRITICAL_SECTION) '离开临界区 '几个重要的函数举例
'ObjPtr：返回对象实例私有域的地址。 'StrPtr：返回字符串第一个字的地址。 'VarPtr：返回变量的地址。 '全局的form的句柄！
Public formhandle As Long '临界数据结构 Public sect As CRITICAL_SECTION Sub OutText1() '过程一
Dim i As Long Dim dc As Long Dim s As String dc = GetDC(formhandle) '获取窗体句柄的DC For i = 1 To 100000 s = CStr(i) Call SetBkColor(dc, &HF0F0F0) '设置绘制区域的背景色，也起清除作用 Call TextOut(dc, 10, 10, s, Len(s)) '输出文本！ Call Sleep(40) '等待 Next Call ReleaseDC(formhandle, dc) '释放资源！ ' Call EnterCriticalSection(sect) ' 上下表示该处为临界区，如果要对工程全局变量做操作，最好在该区域内 ' 否则线程同步过程中，非常容易让程序崩溃 ' Call LeaveCriticalSection(sect) End Sub Sub OutText2() '和过程一类似
Dim i As Long Dim dc As Long Dim s As String dc = GetDC(formhandle) For i = 1 To 100000 s = CStr(i) Call SetBkColor(dc, &HF0F0F0) Call TextOut(dc, 10, 80, s, Len(s)) '文本位置改变了 Call Sleep(20) '延时改变了 Next Call ReleaseDC(formhandle, dc) ' Call EnterCriticalSection(sect) ' Call LeaveCriticalSection(sect) End Sub '关于为何使用gdi 函数输出文本，这是一个很重要的内容； '程序在记数时用了难用的TextOut 函数，而没有使用标签控件，这是因为 'vb的组件不都是线程安全的，当多线程访问不是线程安全的组件，那么会 '产生严重错误。 'mailto:chinasf@Hotmail.com
'作者：萧寒(410000) --------------------------------------------
切换中文输入法
Option Explicit
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" _ (ByVal pwszKLID As String) As Long Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" _ (ByVal hkl As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long Private Declare Function ActivateKeyboardLayout Lib "user32" _ (ByVal hkl As Long, ByVal flags As Long) As Long Const IME_CONFIG_GENERAL = 1 Const KLF_REORDER = &H8 Const KLF_ACTIVATE = &H1 Dim La(15) As Long
Dim LayoutName() As String Private Sub Form_Load()
'获取输入法 Dim strTemp As String * 256 Dim x As Integer, i As Integer '获得输入法总数 x = GetKeyboardLayoutList(32, La(1)) If x = 0 Then Exit Sub ReDim LayoutName(x) As String For i = 0 To x ImmGetDescription La(i), strTemp, 256 If InStr(strTemp, Chr(0)) = 1 Then LayoutName(i) = "英语（美国）" Else LayoutName(i) = Left(strTemp, InStr(strTemp, Chr(0))) End If Next '加入列表 For i = 0 To x Combo1.AddItem LayoutName(i) Next Combo1.ListIndex = 0 End Sub Private Sub Text1_GotFocus()
'设置输入法 ActivateKeyboardLayout La(Combo1.ListIndex), 1 End Sub 查询回收站 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00
Begin VB.Form Form1 BorderStyle = 1 'Fixed Single Caption = "Query Recycle Bin" ClientHeight = 2715 ClientLeft = 5505 ClientTop = 3660 ClientWidth = 3195 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 2715 ScaleWidth = 3195 Begin VB.PictureBox Picture1 Appearance = 0 'Flat AutoRedraw = -1 'True BorderStyle = 0 'None ForeColor = &H80000008& Height = 615 Left = 2550 Picture = "Form1.frx":0000 ScaleHeight = 615 ScaleWidth = 615 TabIndex = 7 Top = 1575 Width = 615 End Begin VB.CheckBox Check1 Caption = "全部" Height = 375 Left = 150 TabIndex = 6 Top = 1560 Width = 1575 End Begin VB.DriveListBox Drive1 Height = 315 Left = 150 TabIndex = 3 Top = 150 Width = 2895 End Begin VB.CommandButton Command1 Caption = "查看" Default = -1 'True Height = 495 Left = 855 TabIndex = 0 Top = 2100 Width = 1485 End Begin VB.Label Label4 Height = 255 Left = 975 TabIndex = 5 Top = 1125 Width = 2040 End Begin VB.Label Label2 Height = 255 Left = 1815 TabIndex = 2 Top = 675 Width = 1200 End Begin VB.Label Label3 Caption = "Bytes:" Height = 255 Left = 150 TabIndex = 4 Top = 1125 Width = 840 End Begin VB.Label Label1 Caption = "Number of Items:" Height = 375 Left = 150 TabIndex = 1 Top = 675 Width = 1905 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function SHQueryRecycleBin Lib "shell32.dll" _
Alias "SHQueryRecycleBinA" (ByVal pszRootPath As String, _ pSHQueryRBInfo As SHQUERYRBINFO) As Long Private Type int64
LowPart As Long HighPart As Long End Type Private Type SHQUERYRBINFO
cbSize As Long ' SHQUERYRBINFO结构变量的大小 i64Size As int64 ' 回收站中对象大小 i64NumItems As int64 ' 回收站中对象数名 End Type Private Sub Command1_Click()
Dim pSHQueryRBInfo As SHQUERYRBINFO pSHQueryRBInfo.cbSize = Len(pSHQueryRBInfo) If Check1.Value Then SHQueryRecycleBin "", pSHQueryRBInfo Else SHQueryRecycleBin Drive1.Drive, pSHQueryRBInfo End If ' Items in Recycle Bin Label2.Caption = pSHQueryRBInfo.i64NumItems.LowPart ' Bytes in Recycle Bin Label4.Caption = pSHQueryRBInfo.i64Size.LowPart & " bytes" End Sub ------------------------------------------------
'任务栏的显示与隐藏 Private Const SW_HIDE = 0
Private Const SW_NORMAL = 1 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private hTaskWnd As Long Private Sub Command1_Click() Call ShowWindow(hTaskWnd, SW_HIDE) End Sub Private Sub Command2_Click()
Call ShowWindow(hTaskWnd, SW_NORMAL) End Sub Private Sub Form_Load()
hTaskWnd = FindWindow("shell_traywnd", "") End Sub --------------------------------------------------------- 搜寻所有字体名称
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_FINDSTRING = &H14C
Private Sub Combo1_Change()
Dim iStart As Integer Dim sString As String Static iLeftOff As Integer iStart = 1 iStart = Combo1.SelStart If iLeftOff <> 0 Then Combo1.SelStart = iLeftOff iStart = iLeftOff End If sString = CStr(Left(Combo1.Text, iStart)) Combo1.ListIndex = SendMessage(Combo1.hwnd, B_FINDSTRING, -1, ByVal CStr(Left(ombo1.Text, iStart))) If Combo1.ListIndex = -1 Then iLeftOff = Len(sString) Combo1.Text = sString End If Combo1.SelStart = iStart iLeftOff = 0 End Sub Private Sub Form_Load()
Dim i As Integer For i = 0 To Screen.FontCount - 1 Combo1.AddItem Screen.Fonts(i) Next i End Sub ----------------------------------------------- 隐藏Windows开始按钮 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form frmMain Caption = "隐藏Windows开始按钮" ClientHeight = 3195 ClientLeft = 60 ClientTop = 345 ClientWidth = 4680 LinkTopic = "Form1" ScaleHeight = 3195 ScaleWidth = 4680 StartUpPosition = 3 '窗口缺省 Begin VB.OptionButton Option1 Caption = "隐藏Windows开始按钮" Height = 495 Index = 1 Left = 1268 TabIndex = 1 Top = 1650 Width = 2145 End Begin VB.OptionButton Option1 Caption = "显示Windows开始按钮" Height = 495 Index = 0 Left = 1268 TabIndex = 0 Top = 1050 Value = -1 'True Width = 2145 End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _ ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function ShowWindow Lib "user32" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Const SW_HIDE = 0
Private Const SW_SHOW = 5 Private Sub Form_Unload(Cancel As Integer)
If Option1(1).Value Then Call Option1_Click(0) End Sub Private Sub Option1_Click(Index As Integer)
Dim hLong As Long Dim hwnd As Long hwnd = FindWindow("Shell_TrayWnd", vbNullString) hLong = FindWindowEx(hwnd, 0, "Button", vbNullString) Select Case Index Case 0 ShowWindow hLong, SW_SHOW Case 1 ShowWindow hLong, SW_HIDE End Select 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 ------------------------------------------------------ '重新启动Windows 2000 / NT系统 'Reboots a Windows 2000 PC. Many examples shell to the kernel and just kill the PC. This does it properly and takes into account a user privilages.
'API Calls used for RebootPC
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_QUERY = &H8 Private Const SE_PRIVILEGE_ENABLED = &H2 Private Const EWX_SHUTDOWN As Long = 1 Private Const EWX_FORCE As Long = 4 Private Const EWX_REBOOT = 2 Private Type LUID UsedPart As Long IgnoredForNowHigh32BitPart As Long End Type Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long TheLuid As LUID Attributes As Long End Type Private Declare Function ExitWindowsEx Lib "user32" _
(ByVal dwOptions As Long, ByVal dwReserved As Long) As Long Private Declare Function GetCurrentProcess Lib "kernel32" () As Long Private Declare Function OpenProcessToken Lib "advapi32" _ (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _ (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long Private Declare Function AdjustTokenPrivileges Lib "advapi32" _ (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _ NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _ PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long Sub RebootPC() On Local Error GoTo RebootPC_ErrorHandler Const csProcName = "RebootPC" Dim hProcessHandle As Long Dim hTokenHandle As Long Dim tmpLuid As LUID Dim tkpNew As TOKEN_PRIVILEGES Dim tkpPrevious As TOKEN_PRIVILEGES Dim lBufferNeeded As Long hProcessHandle = GetCurrentProcess()
Call OpenProcessToken(hProcessHandle, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hTokenHandle) ' Get the LUID for the shutdown privilege
Call LookupPrivilegeValue("", "SeShutdownPrivilege", tmpLuid) tkpNew.PrivilegeCount = 1 ' One privilege to set
tkpNew.TheLuid = tmpLuid tkpNew.Attributes = SE_PRIVILEGE_ENABLED ' Enable the shutdown privilege in the access token of this process.
lBufferNeeded = 0 Call AdjustTokenPrivileges(hTokenHandle, False, tkpNew, Len(tkpPrevious), tkpPrevious, lBufferNeeded) ' Force a Reboot (no option to save files to cancel out)
Call ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, &HFFFF) Exit Sub
RebootPC_ErrorHandler: 'Call RaiseError(csModName, csProcName, Err.Number, Err.Description) End Sub Private Sub Command1_Click()
RebootPC End Sub --------------------------------------------------------- 模拟喷枪(鼠标轨迹) 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form frmMain Caption = "Paint (右键单击-清空)" ClientHeight = 4125 ClientLeft = 60 ClientTop = 345 ClientWidth = 5955 Icon = "frmMain.frx":0000 LinkTopic = "Form1" ScaleHeight = 4125 ScaleWidth = 5955 StartUpPosition = 3 '窗口缺省 WindowState = 2 'Maximized Begin VB.Timer Timer1 Enabled = 0 'False Interval = 1 Left = 1755 Top = 1350 End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _ ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Const SW_SHOW = 5 Dim nX, nY As Long
Private Sub Form_Activate()
With Me .AutoRedraw = True .BackColor = vbWhite End With End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Timer1.Enabled = True nX = X nY = Y End If End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Timer1.Enabled = True nX = X nY = Y End If End Sub Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = False '鼠标右键单击，清空 If Button = 2 Then Me.Cls End Sub Private Sub Timer1_Timer()
Me.DrawWidth = 1 For i = -10 To 10 For j = -10 To 10 PSet (nX + Rnd * i * 100, nY + Rnd * j * 100) Next j Next i End Sub -------------------------------------------------------------- VB中App.path的注意事项 VB中,App.path可以返回当前执行文件的所在文件夹,使得程序放在硬盘的任何地方都能正常运行,这个方法在编VB时很常用。如：我把我的程序及相关文件放在c:\programx中,运行该文件夹下的xxx.exe（即c:\programx\xxx.exe）,而程序中要调用该文件夹下的pic1.jpg,则该路径可以写成App.path & "\pic1.jpg",其中App.path返回的值为"c:\programx",这样,即使把c:中的programx文件夹搬到d:\,返回路径也会自动变成"d:\programx\pic1.jpg"。这个程序看来似乎没有问题,但是,如果我们把c:\programx\下的文件全都搬到d:\下,而不放在任何文件夹下,返回的路径就会变成"d:\\pic1.jpg",发生错误！还有,如果程序中使用了DirListBox的path属性来返回路径时,也会发生类似的错误。因此,程序中必须对这些情况做相应处理。 Dim strPath As String
strPath = App.path If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 屏幕放大镜
【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Form1 BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Form1" ClientHeight = 3000 ClientLeft = 45 ClientTop = 390 ClientWidth = 3000 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 200 ScaleMode = 3 'Pixel ScaleWidth = 200 StartUpPosition = 3 '窗口缺省 Begin VB.Timer Timer1 Interval = 10 Left = 0 Top = 0 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Type POINTAPI
x As Long y As Long End Type Const Srccopy = &HCC0020
Const Swp_nomove = &H2 Const Swp_nosize = &H1 Const Flags = Swp_nomove Or Swp_nosize Const hwnd_topmost = -1 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 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function StretchBlt Lib "gdi32" _ (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _ ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _ ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Dim pos As POINTAPI Private Sub Form_Load()
SetWindowPos hwnd, hwnd_topmost, 0, 0, 0, 0, Flags End Sub Private Sub start()
Dim sx As Integer Dim sy As Integer GetCursorPos pos sx = IIf(pos.x < 50 Or pos.x > 590, IIf(pos.x < 50, 0, 540), pos.x - 50) sy = IIf(pos.y < 50 Or pos.y > 430, IIf(pos.y < 50, 0, 380), pos.y - 50) Caption = "坐标" & sx & "," & sy StretchBlt hdc, 0, 0, 200, 200, GetDC(0), sx, sy, 100, 100, Srccopy End Sub Private Sub Timer1_Timer()
start End Sub ----------------------------------------- 随机图像的魅力 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 5490 ClientLeft = 60 ClientTop = 450 ClientWidth = 7365 LinkTopic = "Form1" ScaleHeight = 5490 ScaleWidth = 7365 StartUpPosition = 3 '窗口缺省 Begin VB.CommandButton Command5 Caption = "Command5" Height = 495 Left = 5760 TabIndex = 6 Top = 4200 Width = 1215 End Begin VB.CommandButton Command4 Caption = "Command4" Height = 495 Left = 4440 TabIndex = 5 Top = 4200 Width = 1215 End Begin VB.CommandButton Command3 Caption = "Command3" Height = 495 Left = 3120 TabIndex = 4 Top = 4200 Width = 1215 End Begin VB.CommandButton Command2 Caption = "Command2" Height = 495 Left = 1800 TabIndex = 3 Top = 4200 Width = 1215 End Begin VB.CommandButton Command1 Caption = "Command1" Height = 495 Left = 480 TabIndex = 2 Top = 4200 Width = 1215 End Begin VB.PictureBox Picture2 Height = 3735 Left = 3840 Picture = "Form1.frx":0000 ScaleHeight = 3675 ScaleWidth = 3315 TabIndex = 1 Top = 240 Width = 3375 End Begin VB.PictureBox Picture1 Height = 3735 Left = 360 ScaleHeight = 3675 ScaleWidth = 3315 TabIndex = 0 Top = 240 Width = 3375 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '随机图像的魅力 '在VB中提供了相当强的绘图功能, 可以在窗口或图形框中利用各种命令绘制各种图形, '灵活使用这些绘图命令不仅可以完成许多特殊的功能, 而且可以为WINDOWS 的程序界面增加许多活力, '特别是那些巧妙的随机图像则更具有特殊的魅力, 下面仅以三种随机动画为例, 演示VB中随机动画图像的风采。 '一?随机简单图形动画
'---- 完成此工作主要的直接使用VB中的作图命令, 比如画点函数PSet(X,Y),COLOR, '其中X Y为图形坐标系统的坐标, COLOR表示颜色值,可用QBColor(x)或RGB(r,g,b)等形式表示, '同时可以控制画点的半径长度,即通过设置Drawwidth 属性, 当半径大于1时实际上此命令是画一个实心圆, '当然也可以利用Circle命令直接绘制圆形。VB中还提供了随机数产生手段,即RND内部函数, '它可以产生0到1之间的随机数, 利用此函数可以随机确定画点的位置、点的颜色、点的半径等， '这样即可以实现在固定区域内进行随机画圆操作, 其中随机位置的确定必须根据作图区域进行确定, '具体可用 ScaleWidth及Scaleheight属性进行确定。为了实现连续动画效果, '可利用时间控件或"DoEvents" 命令实现后台处理, 具体请见文后的Command1_Click事件中的程序代码。 '如果把程序改为随机画矩形或空心圆，或者灵活控制画圆的半径, 则会产生另外的艺术效果, '比如在一片黑色的屏幕上画出随机的小点, 就象夜空中的点点繁星。 '二?随机文字动画
'---- 在VB中可利用"Print"命令进行字符串的显示工作,此命令一般只在当前位置显示字符串, '但具体操作时可通过 CurrentX和CurrentY 控制字符串显示位置,通过FontSize 控制字体的尺寸, '通过ForeColor和BackColor控制字符的前景色和背景色, 如果把上述的各项属性值均采用RND 进行随机产生, '即会形成随机字符显示效果, 比如在一个图形框中显示一些新年贺辞, 同时播放美妙的音乐, '那将是一份极好的新年礼物。需要注意一点，由于字体互相覆盖，长时间显示会使窗口显得乱一些， '所以最好按一定时间用 "CLS"命令进行窗口清除。此处说明一下颜色的控制技巧, '如果使用QBColor(Rnd*15)方式定义随机颜色,只能在16种颜色中随机产生, '而采用RGB(Rnd*256,Rnd*256,Rnd*256) 方式则可以产生256*256*256种不同的颜色, '但具体的颜色特性受当前WINDOWS 屏幕模式的限制。具体操作方式请见文后Command2_Click事件中的代码。 '三?立体图形随机动画
'---- 上面只是直接利用绘图语句进行简单的动画, 如果通过这些命令绘制成一定的立体图形, '并实行随机动画操作, 那将更具有特殊的艺术效果。 '比如下面两行简单的命令将画出一个具有强烈立体感效果的三角锥体, 其中(M,N) 为锥体的顶端坐标: 'Picture1.Line (m, n + 2.5 * i)-(m + i / 2, n + 2 * i), RGB(180, 180, 180) 'Picture1.Line (m, n + 2.5 * i)-(m - i / 2, n + 2 * i), RGB(80, 80, 80) '---- 如果把屏幕的底色置为暗黄色, 在此窗口内的随机位置画出大小不一的三角锥, '就象在黄色的沙漠上建起了无数的金字塔, 具有一种特殊的情趣。 '具体操作方法请见文后程序中的Command3_Click事件中的代码。 '四?随机显示图像
'---- 在VB中不仅提供了完善的做图方法, 而且在绘图方法中还可以灵活的处理图像文件, '其中提供了一个方便的图像复制命令即: PaintPicture, 此命令的功能与API 函数 BitBlt类似, '但由于不用做API函数说明,所以更有它的方便之处, 语法格式: 'PaintPicture Pic, destX, destY, destWidth, destHeight, scrX, scrY, scrWidth, scrHeight '其中Pic:为图片对象, 如图形框Picture等; 'destX,destY:目标图像位置; 'destWidth,destHeight:目标图像尺寸; 'scrX,scrY:原图像的裁剪坐标; 'scrWidth,scrHeight:原图像的裁剪尺寸; '---- 从以上可以看出，目标图像的位置可以随机改变，不仅如此，通过改变destWidth与destHeight值,
'还可以改变复制后的图像的尺寸, 实现放大或缩小图像显示, 甚至可以置这两个属性为负值, '这样可使目标图像在水平方向翻转，实现特殊效果的图像显示, 灵活运用RND 随机函数确定上述各个参数, '可取得理想的随机图像显示效果。具体操作方法请见文后程序Command4_Click事件中的代码。 '---- 文后是一个完成上述随机动画的完整演示程序，需要在From1 窗体中安放两个图形框Picture(1-2) '及四个命令按钮Command1-5,然后把下面的代码填入相应的事件处,运行此程序之后, '按下按钮1则在图形框中进行随机画圆演示, '按下按钮2 则在图形框中进行随机文字显示, '按下按钮 3 则在图形框中随机显示三角锥体, '按下按钮4 则进行随机图像显示, '按下按钮5 则退出程序。 (待续) 续)
'注释: 程序准备 Private Sub Form_Load() Command1.Caption = "随机画圆" Command2.Caption = "随机文字" Command3.Caption = "立体图形" Command4.Caption = "随机图像" Command5.Caption = "退出" Form1.ScaleMode = 1 Picture1.ScaleMode = 1 End Sub '注释: 随机画圆动画
Private Sub Command1_Click() Dim XPos, YPos Picture1.Cls Do nn = Int(100 * Rnd) If nn > 0 Then Picture1.DrawWidth = nn End If XPos = Rnd * Picture1.ScaleWidth YPos = Rnd * Picture1.ScaleHeight Picture1.PSet (XPos, YPos), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Loop End Sub '注释: 随机文字动画
Private Sub Command2_Click() Picture1.Cls Do nn = Int(45 * Rnd) If nn > 0 Then Picture1.FontSize = nn End If Picture1.CurrentX = Rnd * Picture1.ScaleWidth - 1000 Picture1.CurrentY = Rnd * Picture1.ScaleHeight Picture1.ForeColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256) Picture1.Print "随机 OK!" n = n + 1 If n > 50 Then n = 0 Picture1.BackColor = QBColor(Rnd * 15) End If DoEvents Loop End Sub '注释: 立体随机动画
Private Sub Command3_Click() Dim m, n Picture1.DrawWidth = 1 Picture1.BackColor = RGB(210, 150, 0) Picture1.Cls Do m = Rnd * Picture1.ScaleWidth n = Rnd * Picture1.ScaleHeight - 500 For i = 0 To Rnd * 800 Picture1.Line (m, n + 2.5 * i)-(m + i / 2, n + 2 * i), RGB(180, 180, 180) Picture1.Line (m, n + 2.5 * i)-(m - i / 2, n + 2 * i), RGB(80, 80, 80) Next i DoEvents Loop End Sub '注释: 随机图像显示
Private Sub Command4_Click() Do xx = Rnd * Picture1.Width yy = Rnd * Picture1.Height Picture1.PaintPicture Picture2.Picture, xx, yy, Picture2.Width, Picture2.Height DoEvents Loop End Sub '注释: 退出按钮
Private Sub Command5_Click() End End Sub 读写ini配置文件的模块 【Class Code:将下面代码用记事本保存为 CIniFile.cls(类模块文件),此括弧及括弧内容除外】 VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CIniFile" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _ (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, _ ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" _ (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, _ ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _ (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _ ByVal lpDefault As String, ByVal lpReturnedString As String, _ ByVal nSize As Long, ByVal lpFileName As String) As Long 'INI文件名和错误信息
Private IniFileName As String Public ErrorMsg As String '------------------------------------------------------------ '调用方法： 'Dim IniF As New CIniFile 'IniF.SpecifyIni (App.Path & "\Temp.ini") '写入键 'IniF.WriteString "段名", "键名", "键值" '读取键值 'Dim P As String 'P = IniF.ReadString("段名", "键名", 20) '20是长度 '------------------------------------------------------------ '对属性进行初始化
Private Sub Class_Initialize() IniFileName = vbNullString ErrorMsg = vbNullString End Sub '指定INI文件名 Public Sub SpecifyIni(FilePathName) IniFileName = Trim(FilePathName) End Sub '如果没有指定INI文件
Private Function NoIniFile() As Boolean NoIniFile = True If IniFileName = vbNullString Then ErrorMsg = "没有指定 INI 文件" Exit Function End If ErrorMsg = vbNullString NoIniFile = False End Function '向INI文件中写入一个键值，如果键和section不存在则创建 Public Function WriteString(Section As String, key As String, _ Value As String) As Boolean WriteString = False If NoIniFile() Then Exit Function End If If WritePrivateProfileString(Section, key, Value, IniFileName) = 0 Then ErrorMsg = "写入失败" Exit Function End If WriteString = True End Function '在 INI 文件中读取一个键值，作为字符串返回
Public Function ReadString(Section As String, key As String, _ Size As Long) As String Dim ReturnStr As String Dim ReturnLng As Long ReadString = vbNullString If NoIniFile() Then Exit Function End If ReturnStr = Space(Size) ReturnLng = GetPrivateProfileString(Section, key, _ vbNullString, ReturnStr, Size, IniFileName) ReadString = Left(ReturnStr, ReturnLng) End Function '在INI文件中读取一个整数值 Public Function ReadInt(Section As String, key As String) As Long Dim ReturnLng As Long ReadInt = 0 ReturnLng = GetPrivateProfileInt(Section, key, 0, IniFileName) If ReturnLng = 0 Then ReturnLng = GetPrivateProfileInt(Section, key, 1, IniFileName) If ReturnLng = 1 Then ErrorMsg = "不能读取" Exit Function End If End If ReadInt = ReturnLng End Function ------------------------------------------------------------ 设置文件的属性 'Form Code: '方法一
'SetAttr '语法:SetAttr pathname, Attributes 'pathname 必要参数。用来指定一个文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。 'Attributes 必要参数。常数或数值表达式，其总和用来表示文件的属性。 'Attributes 参数设置可为: '常数 值 描述 'vbNormal 0 常规（缺省值） 'VbReadOnly 1 只读。 'vbHidden 2 隐藏。 'vbSystem 4 系统文件 'vbArchive 32 上次备份以后，文件已经改变 '注意 这些常数是由 VBA 所指定的，在程序代码中的任何位置，可以使用这些常数来替换真正的数值。
'如果想要给一个已打开的文件设置属性，则会产生运行时错误。 Private Sub Command1_Click()
SetAttr App.Path & "\abc.txt", vbHidden + vbReadOnly End Sub '方法二 API函数,见模块代码
Private Sub Command2_Click() '设置为只读 + 隐藏 SetFileA App.Path & "\abc.txt" '读取属性 Debug.Print GetFileA(App.Path & "\abc.txt") End Sub 'Class Code: '设置属性
Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" _ (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long '读取属性 Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _ (ByVal lpFileName As String) As Long Const FILE_ATTRIBUTE_READONLY = &H1 '只读
Const FILE_ATTRIBUTE_HIDDEN = &H2 '隐藏 Const FILE_ATTRIBUTE_SYSTEM = &H4 '系统 'Const FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_ARCHIVE = &H20 '保存(存档) Const FILE_ATTRIBUTE_NORMAL = &H80 '常规(一般) Const FILE_ATTRIBUTE_TEMPORARY = &H100 '临时 Const FILE_ATTRIBUTE_COMPRESSED = &H800 '压缩 '要设置两种以上属性,可用 OR 或 + 连接 Public Sub SetFileA(ByVal FileName As String)
'设置为只读 + 隐藏 SetFileAttributes FileName, FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN '取消设置(设置成常规) 'SetFileAttributes FileName, FILE_ATTRIBUTE_NORMAL End Sub Public Function GetFileA(ByVal FileName As String) As String
'读取文件属性 Dim strFileAttr As String Dim FileAtt FileAtt = GetFileAttributes(FileName) If FileAtt And FILE_ATTRIBUTE_READONLY Then strFileAttr = strFileAttr & "只读 " If FileAtt And FILE_ATTRIBUTE_HIDDEN Then strFileAttr = strFileAttr & "隐藏 " If FileAtt And FILE_ATTRIBUTE_SYSTEM Then strFileAttr = strFileAttr & "系统 " If FileAtt And FILE_ATTRIBUTE_ARCHIVE Then strFileAttr = strFileAttr & "存档 " If FileAtt And FILE_ATTRIBUTE_NORMAL Then strFileAttr = strFileAttr & "常规 " If FileAtt And FILE_ATTRIBUTE_TEMPORARY Then strFileAttr = strFileAttr & "临时 " If FileAtt And FILE_ATTRIBUTE_COMPRESSED Then strFileAttr = strFileAttr & "压缩 " GetFileA = strFileAttr End Function ---------------------------------------------------
改变ListIndex而不发生Click事件 'Form Code: '在修改 Combo 或 Listview 的ListIndex 时， 会发生 Click 事件， 下面的函数可以阻止该事件 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_GETCURSEL = &H147
Const CB_SETCURSEL = &H14E Const LB_SETCURSEL = &H186 Const LB_GETCURSEL = &H188 Public Function SetListIndex(lst As Control, ByVal NewIndex As Long) As Long
'改变ListIndex而不发生Click事件 If TypeOf lst Is ListBox Then Call SendMessage(lst.hWnd, LB_SETCURSEL, NewIndex, 0&) SetListIndex = SendMessage(lst.hWnd, LB_GETCURSEL, NewIndex, 0&) ElseIf TypeOf lst Is ComboBox Then Call SendMessage(lst.hWnd, CB_SETCURSEL, NewIndex, 0&) SetListIndex = SendMessage(lst.hWnd, CB_GETCURSEL, NewIndex, 0&) End If End Function Private Sub Combo1_Click()
'测试Click事件是否发生 Print Combo1.Text End Sub Private Sub Command1_Click()
'设置控件ListIndex=2 SetListIndex Combo1, 2 End Sub Private Sub Command2_Click()
''设置控件ListIndex=3 Combo1.ListIndex = 3 End Sub Private Sub Form_Load()
'添加几个项 Dim i As Integer For i = 0 To 5 Combo1.AddItem "项目" & i Next End Sub 关闭MDI窗体中所有的子窗体
建立一个新工程,自然有一个默认Form1存在了,然后设置为子窗体(MDIChild=1),再按下列方法操作并加载此MDI窗体: 【Form Code:将下面代码用记事本保存为 MDIForm1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00 Begin VB.MDIForm MDIForm1 BackColor = &H8000000C& Caption = "MDIForm1" ClientHeight = 6195 ClientLeft = 165 ClientTop = 855 ClientWidth = 9375 LinkTopic = "MDIForm1" StartUpPosition = 3 '窗口缺省 Begin VB.Menu mnu_x Caption = "菜单" Begin VB.Menu mnu_addnew Caption = "添加一个子窗口" End Begin VB.Menu mnu_cls Caption = "关闭所有子窗口" End End End Attribute VB_Name = "MDIForm1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '关闭MDI窗体中所有的子窗体 Private Sub mnu_addnew_Click()
'添加新子窗体 Dim f As New Form1 Static i As Integer i = i + 1 f.Caption = "新窗口-" & i End Sub Private Sub mnu_cls_Click()
'卸载所有子窗体 Screen.MousePointer = vbHourglass Do While Not (Me.ActiveForm Is Nothing)
Unload Me.ActiveForm Loop Screen.MousePointer = vbDefault End Sub ----------------------------------------------------------------- 利用 UnloadMode 来控制窗体的卸载
'在QueryUnload事件中,Visual Basic提供了UnloadMode参数,利用这个参数, '我们可以控制窗体的卸载. Option Explicit
Private Sub Command1_Click()
Unload Me End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'若不是用代码卸载,则失效 If UnloadMode <> 1 Then Cancel = True End If End Sub 'UnloadMode 参数返回下列值:
'常数 值 描述 'vbFormControlMenu 0 用户从窗体上的“控件”菜单中选择“关闭”指令。 'vbFormCode 1 Unload 语句被代码调用。 'vbAppWindows 2 当前 Microsoft Windows 操作环境会话结束。 'vbAppTaskManager 3 Microsoft Windows 任务管理器正在关闭应用程序。 'vbFormMDIForm 4 MDI 子窗体正在关闭，因为 MDI 窗体正在关闭。 -------------------------------------------------------------------
'强制和防止窗口重画csdngoodnight(E-mail:kxufeng@163.com)
'两个按钮和一个CheckBox,一个ListBox '代码
'以下这两条声明对应Command2 Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Sub Command2_Click()
'这则代码演示了如何防止窗口的一部分重画。 '当你要往ListBox或ListView这样的控件里添加许多项时，暂缓重画可以相当地提高处理速度。 '在我的系统上，往一个ListBox中加10000项比原来提速平均82%(CPU:P M 1200Hz) '当你单击Command按钮，代码将往ListBox中添加10000项。 '如果Check1的复选框被选中，Windows将在往ListBox中添加项时防止它的重画。 '操作结束后，会弹出一个对话框报告运行时间。 Dim i As Long Dim lTIme As Long lTIme = timeGetTime() If (Check1.Value = Checked) Then LockWindowUpdate List1.hWnd End If List1.Clear For i = 1 To 10000 List1.AddItem "Test " & i Next i If (Check1.Value = Checked) Then LockWindowUpdate 0 List1.Refresh End If MsgBox "消耗时间: " & timeGetTime - lTIme End Sub Private Sub Command1_Click() '其余代码见模块 '当你单击Command按钮，ListBox的客户区将全部重画。 '对于ListBox，这种效果并不十分明显地显示(会闪动一下,将ListBox控件拉大可以明显些看见效果)， '但这段代码放在这里主要目的，是让你在遇上有东西不能恰当地重画它自己时 '可以有办法解决. RepaintWindow List1 End Sub Private Sub Form_Load()
Dim i As Long For i = 1 To 200 List1.AddItem "TestItem " & i Next i End Sub -------------------------------------------------------- 获得系统内存信息 '模块:
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) Type MEMORYSTATUS dwLength As Long dwMemoryLoad As Long dwTotalPhys As Long dwAvailPhys As Long dwTotalPageFile As Long dwAvailPageFile As Long dwTotalVirtual As Long dwAvailVirtual As Long End Type Public Function GetMemoryInfo()
'获得系统内存信息 Dim Msg As String Dim MemSts As MEMORYSTATUS Dim l As Long GlobalMemoryStatus MemSts Msg = "系统内存信息" & vbCrLf l = MemSts.dwTotalPhys Msg = Msg & "物理内存总量:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf l = MemSts.dwAvailPhys Msg = Msg & "可用物理内存:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf l = MemSts.dwTotalVirtual Msg = Msg & "虚拟内存总量:" & Format(l \ 1024, "###,###,###") & "KB" & vbCrLf l = MemSts.dwAvailVirtual Msg = Msg & "可用虚拟内存:" & Format(l \ 1024, "###,###,###") & "KB" Debug.Print Msg 'Debug.Print MemSts.dwAvailPageFile \ 1024 'Debug.Print MemSts.dwLength 'Debug.Print MemSts.dwTotalPageFile \ 1024 'Debug.Print MemSts.dwMemoryLoad End Function ------------------------------------------------------------------------
取得屏幕分辨率:
msgbox screen.width/15 & " x " & screen.height/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 WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010& Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0 'SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& '上述两种方法都能实现该功能。 End Sub '另有一例,我觉得这样看起来更舒服些: '窗口拖曳相关(同样适用于控件) Dim boolForm_Draw As Boolean Dim sng_DrawX As Single, sng_DrawY As Single Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'如果左键按下 If Button = 1 Then boolForm_Draw = True sng_DrawX = X sng_DrawY = Y End If End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If boolForm_Draw Then Move Me.Left + X - sng_DrawX, Me.Top + Y - sng_DrawY End Sub Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
boolForm_Draw = False End Sub '在程序中注册和注销 OCX 控件 'ComCtl32.OCX 要出测注册或反注册的控件名,在C:\WINDOWS\system32(即系统目录)内
Private Declare Function RegComCtl32 Lib "ComCtl32.OCX" Alias "DllRegisterServer" () As Long Private Declare Function UnRegComCtl32 Lib "ComCtl32.OCX" Alias "DllUnregisterServer" () As Long Const ERROR_SUCCESS = &H0 Private Sub Command1_Click()
On Error GoTo xErr If RegComCtl32 = ERROR_SUCCESS Then MsgBox "注册成功" Else MsgBox "注册失败" End If Exit Sub xErr: If Err.Number = 53 Then MsgBox "没有此文件" End Sub Private Sub Command2_Click()
On Error GoTo xErr If UnRegComCtl32 = ERROR_SUCCESS Then MsgBox "反注册成功" Else MsgBox "反注册失败" End If Exit Sub xErr: If Err.Number = 53 Then MsgBox "没有此文件" End Sub ------------------------------------------------- 'VB应用程序中打印条形码的方法
'原作者:四川 李佑民 '下面就是我们给出的子过程:
'将字符串 strBarCode 对应的条形码输出到缺省打印机 Private Sub PrintBarCode(ByVal strBarCode As String, _
Optional ByVal intXPos As Integer = 0, _ Optional ByVal intYPos As Integer = 0, _ Optional ByVal intPrintHeight As Integer = 10, _ Optional ByVal bolPrintText As Boolean = True) '参数说明:
'strBarCode - 要打印的条形码字符串 'intXPos, intYPos - 打印条形码的左上角坐标(缺省为(0,0),坐标刻度为:毫米) 'intHeight - 打印高度(缺省为一厘米,坐标刻度为:毫米) 'bolPrintText - 是否打印人工识别字符(缺省为true) If strBarCode = "" Then Exit Sub '不打印空串 '"0-9","A-Z","-","%","$"和"*" 的条码编码格式,总共 40 个字符 Static strBarTable(39) As String '初始化条码编码格式表 strBarTable(0) = "001100100" '0 strBarTable(1) = "100010100" '1 strBarTable(2) = "010010100" '2 strBarTable(3) = "110000100" '3 strBarTable(4) = "001010100" '4 strBarTable(5) = "101000100" '5 strBarTable(6) = "011000100" '6 strBarTable(7) = "000110100" '7 strBarTable(8) = "100100100" '8 strBarTable(9) = "010100100" '9 strBarTable(10) = "100010010" 'A strBarTable(11) = "010010010" 'B strBarTable(12) = "110000010" 'C strBarTable(13) = "001010010" 'D strBarTable(14) = "101000010" 'E strBarTable(15) = "011000010" 'F strBarTable(16) = "000110010" 'G strBarTable(17) = "100100010" 'H strBarTable(18) = "010100010" 'I strBarTable(19) = "001100010" 'J strBarTable(20) = "100010001" 'K strBarTable(21) = "010010001" 'L strBarTable(22) = "110000001" 'M strBarTable(23) = "001010001" 'N strBarTable(24) = "101000001" 'O strBarTable(25) = "011000001" 'P strBarTable(26) = "000110001" 'Q strBarTable(27) = "100100001" 'R strBarTable(28) = "010100001" 'S strBarTable(29) = "001100001" 'T strBarTable(30) = "100011000" 'U strBarTable(31) = "010011000" 'V strBarTable(32) = "110001000" 'W strBarTable(33) = "001011000" 'X strBarTable(34) = "101001000" 'Y strBarTable(35) = "011001000" 'Z strBarTable(36) = "000111000" '- strBarTable(37) = "100101000" '% strBarTable(38) = "010101000" '$ strBarTable(39) = "001101000" '* '保存打印机 ScaleMode
Dim intOldScaleMode As ScaleModeConstants intOldScaleMode = Printer.ScaleMode '保存打印机 DrawWidth
Dim intOldDrawWidth As Integer intOldDrawWidth = Printer.DrawWidth '保存打印机 Font
Dim fntOldFont As StdFont Set fntOldFont = Printer.Font Printer.ScaleMode = vbTwips '设置打印用的坐标刻度为缇(twip=1)
Printer.DrawWidth = 1 '线宽为 1 Printer.FontName = "宋体" '打印在条码下方字符的字体和大小 Printer.FontSize = 10 Dim strBC As String '要打印的条码字符串
strBC = UCase(strBarCode) '将以毫米表示的 X 坐标转换为以缇表示
Dim x As Integer x = Printer.ScaleX(intXPos, vbMillimeters, vbTwips) '将以毫米表示的 Y 坐标转换为以缇表示
Dim y As Integer y = Printer.ScaleY(intYPos, vbMillimeters, vbTwips) '将以毫米表示的高度转换为以缇表示
Dim intHeight As Integer intHeight = Printer.ScaleY(intPrintHeight, vbMillimeters, vbTwips) '是否在条形码下方打印人工识别字符
If bolPrintText = True Then '条码打印高度要减去下面的字符显示高度 intHeight = intHeight - Printer.TextHeight(strBC) End If Const intWidthCU As Integer = 30 '粗线和宽间隙宽度
Const intWidthXI As Integer = 10 '细线和窄间隙宽度 Dim intIndex As Integer '当前处理的字符串索引 Dim i As Integer, j As Integer, k As Integer '循环控制变量 '添加起始字符
If Left(strBC, 1) <> "*" Then strBC = "*" & strBC End If '添加结束字符
If Right(strBC, 1) <> "*" Then strBC = strBC & "*" End If '循环处理每个要显示的条码字符
For i = 1 To Len(strBC) '确定当前字符在 strBarTable 中的索引 Select Case Mid(strBC, i, 1) Case "*": intIndex = 39 Case "$": intIndex = 38 Case "%": intIndex = 37 Case "-": intIndex = 36 Case "0" To "9": intIndex = CInt(Mid(strBC, i, 1)) Case "A" To "Z": intIndex = Asc(Mid(strBC, i, 1)) - Asc("A") + 10 Case Else MsgBox "要打印的条形码字符串中包含无效字符！当前版本只支持字符 0-9,A-Z,-,%,$和*" End Select '是否在条形码下方打印人工识别字符 If bolPrintText = True Then Printer.CurrentX = x Printer.CurrentY = y + intHeight Printer.Print Mid(strBC, i, 1) End If For j = 1 To 5
If Mid(strBarTable(intIndex), j, 1) = "0" Then '画细线 For k = 0 To intWidthXI - 1 Printer.Line (x + k, y)-Step(0, intHeight) Next k x = x + intWidthXI Else '画宽线 For k = 0 To intWidthCU - 1 Printer.Line (x + k, y)-Step(0, intHeight) Next k x = x + intWidthCU End If '每个字符条码之间为窄间隙
If j = 5 Then x = x + intWidthXI * 3 Exit For End If If Mid(strBarTable(intIndex), j + 5, 1) = "0" Then '窄间隙 x = x + intWidthXI * 3 Else '宽间隙 x = x + intWidthCU * 2 End If Next j Next i Printer.EndDoc '若不想单独打出一页来,可插入其它代码,再回头调此句 '恢复打印机 ScaleMode Printer.ScaleMode = intOldScaleMode '恢复打印机 DrawWidth Printer.DrawWidth = intOldDrawWidth '恢复打印机 Font Set Printer.Font = fntOldFont End Sub '##形状不规则的窗体(超简单,又好用)
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 Declare Function SetLayeredWindowAttributes Lib "user32" _ (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long 'SetLayeredWindowAttributes 参数: 'hwnd:窗体的句柄 'crKey:颜色值 'bAlpha:透明度,取值范围:0-255 'dwFlags:透明方式,可以取两个值:当取值为LWA_ALPHA时,crKey参数无效,bAlpha参数有效; '当取值为LWA_COLORKEY时,bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明[这个功能很有用,我喜欢] :) '我们不必再为建立不规则形状的窗体而调用一大堆区域分析、创建、合并函数了,只需指定透明处的颜色值即可,哈哈哈哈! '原作者：iProgram Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2 Private Const LWA_COLORKEY = &H1 '代码一: 半透明窗体
'Private Sub Form_Load() ' Dim rtn As Long ' rtn = GetWindowLong(hwnd, GWL_EXSTYLE) ' rtn = rtn Or WS_EX_LAYERED ' SetWindowLong hwnd, GWL_EXSTYLE, rtn ' SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA 'End Sub '代码二: 形状不规则的窗体
Private Sub Form_Load() Dim rtn As Long BorderStyler = 0 rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn '将扣去窗口中的蓝色(&HFF0000),你可以将要保留的部分改成非(&HFF0000)颜色值,当然你也可以用其它颜色 '做成BMP位图,加载进来更容易,做个皮肤什么的.... '(之前Print几个打字上面试试看) Me.BackColor = &HFF0000 PrintFont "哈哈哈" SetLayeredWindowAttributes hwnd, &HFF0000, 0, LWA_COLORKEY End Sub Sub PrintFont(str As String)
FontSize = 80 FontName = "黑体" Print str End Sub ------------------------------------------------------------------- 监视某过程总耗时
'获取系统时钟API
Private Declare Function timeGetTime Lib "winmm.dll" () As Long Sub TestLoop()
Dim BeginTime As Long '记录开始时间 BeginTime = timeGetTime() '过程 Dim l As Long Do While l < 50000000 l = l + 1 Loop '回显 Debug.Print "耗时(毫秒):", timeGetTime - BeginTime End Sub Private Sub Command1_Click() TestLoop End Sub ---------------------------------------------------------------------- '取得文件的8.3文件名,和初识Command(带参数运行EXE,参数的取得)
'生成EXE文件,然后将一个长文件名的文件图标拖到新生成的EXE文件上去. '点击EXE文件的按钮,就可以看到转换结果了 Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _ (ByVal lpszLongPath As String, ByVal lpszShortPath As String, _ ByVal cchBuffer As Long) As Long Dim DOSFileName As String '声明dos 文件名
Dim LongFileName As String '声明长文件名 Private Sub Command1_Click() Text1.Text = GetShortFileName(DOSFileName) '文件的短文件名 Text2.Text = LongFileName ''文件的长文件名 End Sub Private Sub Form_Load()
DOSFileName = Command$() '从命令行取得参数 If Len(DOSFileName) > 0 Then MsgBox "Command参数:" & DOSFileName LongFileName = Dir(DOSFileName) '得到长文件名 End Sub Public Function GetShortFileName(ByVal FileName As String) As String
Dim l As Long Dim ShortPath As String Const PATH_LEN& = 164 '获得文件的短文件名(包含路径) ShortPath = String(PATH_LEN + 1, 0) l = GetShortPathName(FileName, ShortPath, PATH_LEN) GetShortFileName = Left(ShortPath, l) End Function '自从进入Win95时代以来,Win95的长文件名给人们带来了很多方便, '但是由于原来的DOS只支持8.3格式,即8个主文件名加上3个扩展名, '所以所有Win95的长文件名都有一个DOS名,具体方法为取原长文件名前6位加～num(其中num为现目录中不重名的序号). '现在的VB已完全支持了长文件名,但是有一点可能没有注意到, '即当用Command()接收从命令行传来的参数时,如果参数是长文件名,则被强制转换成为DOS名,即8.3格式文件名. '由于这两种文件名通用,所以一般情况下不会有什么问题. '但遇到特殊场合就不行了. '有没有办法再把8.3格式的文件名转换为原来的长文件名呢?答案是:可以。 如下内容,保存为*.bat(批处理)于同目录下,然后运行看看,呵呵
: 注:test.exe为上面代码生成的."kxufeng@163.com /s"随便写几个字符吧 test.exe kxufeng@163.com /s --------------------------------------------------------------- '确定是 Windows 的可执行文件
'在文件的第 24 字节，如果为40H，就是 Windows 的可执行文件。 Function WinExeIs(ByVal EXEName As String) As Boolean
'EXEName:文件名(含路径) '没有输入,跳到陷阱 On Error GoTo NullErr '没有此文件,退出 If Dir(EXEName) = "" Then MsgBox "没有这个文件!", vbInformation: Exit Function Dim i As Integer Dim s As String * 1 i = FreeFile Open EXEName For Binary As #i '找24字节 Get i, 25, s Close #i WinExeIs = (Asc(s) = &H40&) Exit Function NullErr: End Function Private Sub Command1_Click()
Dim s As String s = App.Path & "\form1.frm" '一个要测试的文件 MsgBox IIf(WinExeIs(s), "是", "不是") & "Windows可运行的文件", vbInformation End Sub ------------------------------------------------------------------------- 调用Word7拼写检查和统计
'先引用"Microsoft Word 8.0 Object Library"或更高 Option Explicit Dim Doc As New Document
Dim Visi As Boolean '调用Word 97拼写检查
Private Sub Command1_Click() Form1.Caption = "拼写检查" Doc.Range.Text = Text1 '确定范围 Doc.Application.Visible = True '将Word 97变为可见 AppActivate Doc.Application.Caption '激活Word 97 Doc.Range.CheckSpelling '拼写检查 Text1 = Doc.Range.Text
Text1 = Left(Text1, Len(Text1) - 1) AppActivate Caption End Sub '统计单词数
Private Sub Command2_Click() Dim Dlg As Word.Dialog Doc.Range = Text1.Text
Set Dlg = Doc.Application.Dialogs(wdDialogDocumentStatistics) Dlg.Execute '统计单词和字符 Form1.Caption = "单词数:" & Str(Dlg.Words) & "词" & Str(Dlg.Characters) & "字符" '显示统计结果 End Sub Private Sub Form_Load()
Form1.Caption = "调用Word" Text1.Text = "Good good study, Day day up. Shit! English? Chinese?" Command1.Caption = "拼写检查" Command2.Caption = "统计单词" Visi = Doc.Application.Visible '使应用程序可见 End Sub '关闭应用程序
Private Sub Form_Unload(Cancel As Integer) If Visi Then '关闭文件 Doc.Close savechanges:=False Else Doc.Application.Quit savechanges:=False '关闭Word 97 End If End Sub 调用系统文件拷贝对话框 Option Explicit
Private Type SHFILEOPSTRUCT
hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long Const FO_COPY = &H2 Const FOF_ALLOWUNDO = &H40 Private Sub ShellCopyFile(SourceFiles As String, DestFiles As String)
On Error Resume Next Dim Result As Long Dim Fileop As SHFILEOPSTRUCT With Fileop .hwnd = 0 .wFunc = FO_COPY '拷贝一个文件 .pFrom = SourceFiles & vbNullChar & vbNullChar '拷贝目录下所有文件 '.pFrom = "C:\*.*" & vbNullChar & vbNullChar .pTo = DestFiles & vbNullChar & vbNullChar .fFlags = FOF_ALLOWUNDO End With Result = SHFileOperation(Fileop) If Result = 0 And Fileop.fAnyOperationsAborted <> 0 Then MsgBox "操作失败!", vbCritical Or vbOKOnly End If End Sub Private Sub Command1_Click()
'如果文件够大(要超过几秒钟),才能看见对话框 '或者连续两次按键,看看"是否替换"对话框 ShellCopyFile App.Path & "\temp.txt", "c:\" End Sub ------------------------------------------------
'压缩路径名.什么意思?
'C:\Documents and Settings\Administrator\My Documents\temp.txt 压缩成: 'C:\Doc...\temp.txt '很多地方都见过的:在一个有限的空间显示过长的路径名. Private Declare Function PathCompactPath Lib "shlwapi" Alias "PathCompactPathA" _ (ByVal hDC As Long, ByVal lpszPath As String, ByVal dx As Long) As Long '三个参数:
'hDC:设备hDC 'lpszPath:文件地址字符串 'dx:宽度(象素) Private Sub Command1_Click()
Dim lhDC As Long, lWidth As Long Dim strLongFileName As String lhDC = Me.hDC '搞一个超常的地址,长度要大于Label1.Width,不然效果没的看了 'strLongFileName = "C:\Abc\LALA\900\haha\longlong\A\003\TXT\123.txt" '通常"我的文档"的路径都很长,这里就拿它做测试(MyDocumentsDir函数见模块) strLongFileName = MyDocumentsDir(Me) strLongFileName = strLongFileName & "\temp.txt" '设置刻度为象素 Me.ScaleMode = vbPixels '得到需要压缩的长度 lWidth = Label1.Width - Me.DrawWidth '调用函数,返回新的strLongFileName PathCompactPath lhDC, strLongFileName, lWidth '显示 Label1.Caption = strLongFileName End Sub '附模块代码:关于获取"我的文档"路径
Option Explicit '获得我的文档路径
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pIdl As Long, ByVal pszPath As String) As Long Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _ (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long Type SHITEMID cb As Long abID() As Byte End Type Type ITEMIDLIST mkid As SHITEMID End Type Public Function MyDocumentsDir(oForm As Form) As String
Dim IDL As ITEMIDLIST Dim sPath As String * 260 If SHGetSpecialFolderLocation(oForm.hWnd, 5, IDL) = 0 Then If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then '返回我的文档路径 MyDocumentsDir = Left$(sPath, InStr(sPath, vbNullChar) - 1) End If End If End Function ----------------------------------------------------------------------------------- '去掉固定长度字符串右边的Null字符(ASCII值为0)和SPACE字符(ASCII值为32)
'解决一些函数的返回值是260字节长度,首尾部要跟一堆空字符 Public Function PurString(str As String) As String
'去除Null字符 'On Error Resume Next Dim i As Integer For i = 1 To Len(str) '过滤Null字符 If Asc(Mid(str, i, 1)) <> 0 Then PurString = PurString & Mid(str, i, 1) Next '去除首尾空格 PurString = Trim(PurString) '这样也行(不过,要先判断Null字符在左还是在右): 'PurString = Left(str, InStr(str, Chr(0)) - 1) End Function -------------------------------------------------------------------------------------
避免 Null 产生的错误
当我们从数据库读出数据时，有的字段内容可能为 Null，若不加以处理而要将数据赋值给某一字段时，会有错误产生，虽然 VB 本身有提供一个 IsNull 函数以供判断，但是您知道吗，我写了这么多年的 VB 数据库程序，从来没有用过 IsNull 来判断数据库字段值，为什么呢？我又怎么做呢？
其实很简单，我不管从数据库读出来的是不是 Null，写法一律如下：
Text1.Text = adoRS("Field1") & "" 如果这个字段的值是 Null，加上 (&"") 之后就变成了 "" 了！
但是要小心，我的新同事们常常会犯一个错误，我们看看以下二个式子：
1、Text1.Text = Trim(adoRS("Field1")) & "" '(可能是错的) 2、Text1.Text = Trim(adoRS("Field1") & "") '(这样写才对) 第一个式子如果字段值是 Null，使用 Trim$ 便会产生错误，对于这些状况，其实只要记住一个原则即可：
不管从数据库读出之资料要做什么动作，不管三七二十一先加上 (&"") 就对了 再来看看一个例子，以加深印象：
Text1.Text = Format( (adoRS("Field1") & ""), "yymmdd") 另有: 在往SQL Server数据库中添加记录时，每个字段必须给予明确赋值（即在没有给数据表设定缺省规则或给每个字段设定缺省值的情况下），否则便发生错误。因此我用VB编写了一个处理函数，将其放入标准模块，以供相应程序调用。函数首先判断是否给字段赋值，若没有，则根据字段类型的不同赋予不同数值（数字赋零，字符赋空格） Function NoNull(FieldVar As Variant) As Variant
If IsNull(FieldVar) Then '字段没有赋值，判断其类型 If FieldVar.Type = 12 Then '字符型字段，赋空格 NoNull = " " Else '数字型字段，赋0 NoNull = 0 End If Else NoNull = FieldVar End If End Function 'VB处理数据库时求数据表记录总数的最佳方法
'rs 是一个 Recordset
'打开数据库,读取数据到rs代码略 Debug.Print rs.RecordCount
'此行代码的目的就是求出该表中的记录的总数. '此处用到的是"表"对象的RecordCount属性,这样用在一般性况下是正确的,但并不能保证在所有的情况下都能得出正确的结果. '比如说表中的数据量很大,或者是数据库受到过什么损害等等. '如果碰到这种情况,我们可以换用下面的程序: Dim Num As Long
Num = 0 rs.MoveFirst Do While Not rs.EOF() Num = Num + 1 rs.MoveNext Loop Debug.Print Num '这样,最后得到的Num即为正解结果,这种方法的思路是从表的开始处一直顺序走到结尾, '就可以"数"出表中到底有多少条记录.这种方法看起来很笨,但是它却是一个相当准确的方法,大家不防可以试一下. '先看上面一行程序：Debug.Print rs.RecordCount,VB5在读取数据表时并非一次性将全部记录均读入内存
'想想看如果有一个表,里面有一百万个记录甚至一亿个或更多,要想全部读入内存,你的机器能承受得了吗. '只是先读入一部分(在下认为这是VB的优异这处),recordset对象并非表的全部记录,只是已读入内存的部分, '故用rs.recordcount得到的不是表的记录总数. '再看上面第二段程序：
'在下用十万个记录的表对上面这段程序做了个测试,结果花了N分钟,如此的等待很不现实,请看在下的对策： rs.Recordset.MoveLast '将指针移到表的最后一笔记录
Debug.Print rs.Recordset.RecordCount '即可得出正确结果! '或者 rs.Recordset.MoveLast Debug.Print rs.Recordset.AbsolutePosition + 1 '调用绝对位置,因vb的第一笔记录是由0零算起,故要+1. -------------------------------------------------------------------------
0、""(空字串)、Null、Empty、与 Nothing 的区别
先回答以下问题吧！ 经过以下的叙述之后， 变量 A、B、C、D 分别等于 0、 ""、Null、 Empty、 Nothing 的哪一个？ Dim A Dim B As String Dim C As Integer Dim D As Object A 等于 Empty， 因为尚未初始化的「不定型变量」都等于 Empty。但如果检 测 A = "" 或 A = 0， 也都可以得到 True 值。 B 等于 ""， 因为尚未初始化的非固定长度「字串」都等于 "" 。 但请注意 B<> Null。 C 等于 0， 这个还有问题吗？ D 等于 Nothing， 尚未设定有物件的「物件变量」都等于 Nothing， 但请不 要使用 D = Nothing , 而要使用 D Is Nothing 来判断 D 是否等于 Nothing， 因为判断 是否相等的符号是 Is 不是 = 。 最令人迷惑的地方是 Null 这个保留字， 请看以下语句： Print X = Null Print X <> Null 结果都是输出 Null(不是 True 也不是 False)， 这是因为任何一个运算式只 要含有 Null ， 则该运算式就等于 Null， 实际上想要判断某一数据是否为 Null 绝对不能使用： If X = Null Then ' 永远都会得到 Null 而要使用： If IsNull(X) Then 哪一种数据会等于 Null 呢？ 除了含有 Null 运算式之外， 就属没有输入任 何数据的「数据字段」(在数据库中) 会等于 Null。 -------------------------------------------------------------------------- 'keybd_event函数的使用
'下面的函数可以利用kb_event实行一些系统操作 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 Private Sub Command1_Click()
Static i As Integer i = i + 1 DoAction i End Sub 图片到mdb数据库的存取
'Module Code: Option Explicit Public adoRS As Recordset
Public db As Connection '先引用 Microsoft ActiveX Data Object 2.6 或更高版本
'csdngoodnight(Email:kxufeng@163.com) Public Sub PicInMdb(objPictureBox As PictureBox) '将图片写数据库 'objPictureBox: PictureBox图片容器 '将 PictureBox 的图片保存为临时文件 Dim TempFileName As String TempFileName = App.Path & "\pic.tmp" SavePicture objPictureBox.Image, TempFileName On Error GoTo mdbErr Dim Pic_Stream As New ADODB.Stream Pic_Stream.Type = adTypeBinary '类型为二进制数组 Pic_Stream.Open Pic_Stream.LoadFromFile TempFileName '图片路径 'adoRS.AddNew '"PictureOLE": Access数据库的字段(数据类型:OLE 对象) adoRS.Fields("PictureOLE").Value = Pic_Stream.Read adoRS.Update Kill TempFileName '删除临时文件 '关闭记录集 adoRS.Close Exit Sub mdbErr: MsgBox Err.Description, vbOKOnly + vbExclamation, "出错提示" End Sub Public Sub MdbOutPic(objPictureBox As PictureBox)
'从数据库中提取二进制图片数据 'objPictureBox: PictureBox图片容器 Dim TempFileName As String TempFileName = App.Path & "\pic.tmp" On Error GoTo mdbErr Dim Pic_Stream As New ADODB.Stream Pic_Stream.Type = adTypeBinary Pic_Stream.Open Pic_Stream.Write adoRS.Fields("PictureOLE").Value Pic_Stream.SaveToFile TempFileName, adSaveCreateOverWrite '保存临时图片文件 objPictureBox.Picture = LoadPicture(TempFileName) '控件加载 Kill TempFileName '删除临时文件 '关闭记录集 adoRS.Close Exit Sub mdbErr: MsgBox Err.Description, vbOKOnly + vbExclamation, "出错提示" End Sub 【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】 VERSION 5.00
Begin VB.Form Form1 Caption = "将图片写数据库" ClientHeight = 6720 ClientLeft = 60 ClientTop = 450 ClientWidth = 6810 LinkTopic = "Form1" ScaleHeight = 6720 ScaleWidth = 6810 StartUpPosition = 3 '窗口缺省 Begin VB.CommandButton Command5 Caption = "打上这个烙印" Height = 495 Left = 1800 TabIndex = 6 Top = 5640 Width = 1575 End Begin VB.CommandButton Command4 Caption = "清除图片" Height = 495 Left = 3960 TabIndex = 5 Top = 4440 Width = 1575 End Begin VB.CommandButton Command3 Caption = "提取图片" Height = 495 Left = 3960 TabIndex = 4 Top = 3840 Width = 1575 End Begin VB.PictureBox Picture2 AutoSize = -1 'True Height = 3060 Left = 3480 ScaleHeight = 3000 ScaleWidth = 2445 TabIndex = 3 Top = 600 Width = 2505 End Begin VB.CommandButton Command2 Caption = "保存到数据库" Height = 495 Left = 1080 TabIndex = 2 Top = 4440 Width = 1575 End Begin VB.CommandButton Command1 Caption = "载入图片" Height = 495 Left = 1080 TabIndex = 1 Top = 3840 Width = 1575 End Begin VB.PictureBox Picture1 AutoSize = -1 'True Height = 3060 Left = 600 ScaleHeight = 3000 ScaleWidth = 2445 TabIndex = 0 Top = 600 Width = 2505 End Begin VB.Image Image1 Height = 720 Left = 960 Picture = "Form1.frx":0000 Top = 5520 Width = 720 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Sub Command1_Click()
Picture1.Picture = LoadPicture(App.Path & "\Hitomi.jpg") End Sub Private Sub Command2_Click()
'写入图片 '打开表(表名:Picture,两个字段:ID/主键;PictureOLE/数据类型OLE对象) adoRS.Open "SELECT * FROM Picture WHERE ID=22", db, adOpenStatic, adLockOptimistic PicInMdb Picture1 End Sub Private Sub Command3_Click()
'提取图片 adoRS.Open "SELECT * FROM Picture WHERE ID=22", db, adOpenStatic, adLockOptimistic MdbOutPic Picture2 End Sub Private Sub Command4_Click()
Picture1.Picture = LoadPicture("") Picture2.Picture = LoadPicture("") End Sub Private Sub Command5_Click()
'为了看效果,可以弄个烙印在上面(Image1是个图标) Picture1.PaintPicture Image1.Picture, 30, 30, Image1.Width, Image1.Height End Sub Private Sub Form_Load()
On Error Resume Next Set db = New Connection db.CursorLocation = adUseClient '打开数据库(mdb名:Test.mdb) db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;" & _ "Data Source=" & App.Path & "\Test.mdb;Jet OLEDB:" 'Database Password=1234;" Set adoRS = New Recordset Picture1.AutoRedraw = True Picture1.AutoRedraw = True End Sub Private Sub Form_Unload(Cancel As Integer)
On Error GoTo NotState 'On Error Resume Next Debug.Print "adoRS.State", adoRS.State '如果处于打开状态,先关闭 If adoRS.State = adStateOpen Then adoRS.Close Set adoRS = Nothing Debug.Print "db.State", db.State '如果处于打开状态,先关闭 If db.State = adStateOpen Then db.Close Set db = Nothing NotState: Debug.Print Err.Description End Sub 【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】 Type=Exe Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation Reference=*\G{00000206-0000-0010-8000-00AA006D2EA4}#2.6#0#C:\Program Files\Common Files\system\ado\msado26.tlb#Microsoft ActiveX Data Objects 2.6 Library Form=Form1.frm Module=Module1; Module1.bas Startup="Form1" Command32="" Name="工程1" HelpContextID="0" CompatibleMode="0" MajorVer=1 MinorVer=0 RevisionVer=0 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="xufeng" CompilationType=0 OptimizationType=0 FavorPentiumPro(tm)=0 CodeViewDebugInfo=0 NoAliasing=0 BoundsCheck=0 OverflowCheck=0 FlPointCheck=0 FDIVCheck=0 UnroundedFP=0 StartMode=0 Unattended=0 Retained=0 ThreadPerObject=0 MaxNumberOfThreads=1 [MS Transaction Server]
AutoRefresh=1 -------------------------------------------------- ---------------------------- ADO语句+mdb,得到文件中所有的表及类型 Dim rs As New Recordset
'db是一个Connection,这里已经连接(代码略) Set rs = db.OpenSchema(adSchemaTables) Do Until rs.EOF Debug.Print "表名: " & rs!TABLE_NAME & vbCrLf & _ "表类型: " & rs!TABLE_TYPE & vbCrLf rs.MoveNext Loop rs.Close Set rs = Nothing '各种进制的转换(演示) Private Function TenTurnTwo(ByVal lNumber As Long) As String
'10 to 2 Dim i As Integer Do While lNumber > 0 i = lNumber Mod 2 lNumber = lNumber \ 2 TenTurnTwo = Trim(Str(i)) + TenTurnTwo Loop End Function Private Function TwoTurnTen(ByVal varString As String) As Long
'2 to 10 Dim l As Long, i As Long l = Len(varString) For i = 0 To l - 1 TwoTurnTen = TwoTurnTen + Val(Mid(varString, i + 1, 1)) * (2 ^ (l - i - 1)) Next End Function Private Sub Command1_Click() '10 to 2
Dim l As Long l = CLng(Text1.Text) Text2.Text = TenTurnTwo(l) End Sub Private Sub Command2_Click() '2 to 10
Dim varString As String varString = Text2.Text Text1.Text = TwoTurnTen(varString) End Sub Private Sub Command3_Click() '10 to 16
'十进制转换到十六进制,函数:Hex() '然后前置 &H Dim l As Long l = CLng(Text1.Text) Text3.Text = "&H" & Hex(l) End Sub Private Sub Command4_Click() '10 to 8
'十进制转换到八进制,函数:Oct() '然后前置 &0 Dim l As Long l = CLng(Text1.Text) Text4.Text = "&0" & Oct(l) End Sub Private Sub Command5_Click() '16 to 2
Dim l As Long l = CLng(Text3.Text) Text5.Text = TenTurnTwo(l) End Sub Private Sub Command6_Click() '8 to 2
Dim l As Long l = CLng(Text4.Text) Text6.Text = TenTurnTwo(l) End Sub ---------------------------------------------- '取得 DOS 环境变量,使用 Environ 函数
Private Sub Command1_Click() Dim x As Integer Dim Env As String x = 1 Env = Environ(x) Do Until Env = "" Env = Environ(x) Debug.Print Env x = x + 1 Loop End Sub -----------------------------------------------
'采用递归算法删除带有多级子目录的目录
Option Explicit Private Sub Command1_Click()
Dim strPathName As String '设置要删除的目录,此处设置为工作目录下的一个文件夹 '(注:该目录将被彻底删除,即使是只读和系统属性的文件,而不是送到回收站,请设置到一个无用的目录上) strPathName = App.Path & "\aa" '出错则跳出 If strPathName = "" Then Exit Sub On Error GoTo ErrorHandle SetAttr strPathName, vbNormal '此行主要是为了检查文件夹名称的有效性(设置目录属性到常规) '调用 RecurseTree strPathName '返回后显示执行结果 Label1.Caption = "文件夹" & strPathName & "已经删除！" Exit Sub ErrorHandle: '陷阱 MsgBox "无效的文件夹名称:" & strPathName End Sub Sub RecurseTree(CurrPath As String)
Dim sFileName As String Dim sPath As String sPath = CurrPath & "\" '31的含义:31 = vbNormal + vbReadOnly + vbHidden + vbSystem + vbVolume + vbDirectory '即所有属性的目录 sFileName = Dir(sPath, 31) '循环至没有目录 Do While sFileName <> "" If sFileName <> "." And sFileName <> ".." Then If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹 '这里用到递归 RecurseTree sPath & sFileName sFileName = Dir(sPath, 31) Else 'SetAttr:设置文件属性 SetAttr sPath & sFileName, vbNormal Kill (sPath & sFileName) Label1.Caption = sPath & sFileName '显示删除过程 sFileName = Dir End If Else '退至父目录 sFileName = Dir End If DoEvents Loop SetAttr CurrPath, vbNormal RmDir CurrPath Label1.Caption = CurrPath End Sub --------------------------------------------------------------
'读取文件的时间信息
'模块: Const OFS_MAXPATHNAME = 128 Const OF_READ = &H0 Type OFSTRUCT cBytes As Byte fFixedDisk As Byte nErrCode As Integer Reserved1 As Integer Reserved2 As Integer szPathName(OFS_MAXPATHNAME) As Byte End Type Type SYSTEMTIME
wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Type FileTime
dwLowDateTime As Long dwHighDateTime As Long End Type Type BY_HANDLE_FILE_INFORMATION
dwFileAttributes As Long ftCreationTime As FileTime ftLastAccessTime As FileTime ftLastWriteTime As FileTime dwVolumeSerialNumber As Long nFileSizeHigh As Long nFileSizeLow As Long nNumberOfLinks As Long nFileIndexHigh As Long nFileIndexLow As Long End Type Type TIME_ZONE_INFORMATION
bias As Long StandardName(32) As Integer StandardDate As SYSTEMTIME StandardBias As Long DaylightName(32) As Integer DaylightDate As SYSTEMTIME DaylightBias As Long End Type Declare Function GetTimeZoneInformation Lib "kernel32" _ (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long Declare Function OpenFile Lib "kernel32" _ (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long Declare Function GetFileInformationByHandle Lib "kernel32" _ (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Declare Function FileTimeToSystemTime Lib "kernel32" _ (lpFileTime As FileTime, lpSystemTime As SYSTEMTIME) As Long Dim FileHandle As Long Dim FileInfo As BY_HANDLE_FILE_INFORMATION Dim lpReOpenBuff As OFSTRUCT, ft As SYSTEMTIME Dim tZone As TIME_ZONE_INFORMATION Dim dtCreate As Date ' 建立时间
Dim dtAccess As Date ' 存取日期 Dim dtWrite As Date ' 修改时间 Dim bias As Long Public Function FileTimeZone(strFile As String)
' 先取得文件的 File Handle
FileHandle = OpenFile(strFile, lpReOpenBuff, OF_READ) ' 利用 File Handle 读取文件信息 Call GetFileInformationByHandle(FileHandle, FileInfo) Call CloseHandle(FileHandle) ' 读取 Time Zone 信息,因为上一步骤的档案时间是"格林威治"时间 Call GetTimeZoneInformation(tZone) bias = tZone.bias ' 时间差,以"分钟"为单位 Call FileTimeToSystemTime(FileInfo.ftCreationTime, ft) ' 转换时间资料结构 dtCreate = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond) Debug.Print "创建时间:", dtCreate Call FileTimeToSystemTime(FileInfo.ftLastAccessTime, ft) dtAccess = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond) Debug.Print "存取时间:", dtAccess Call FileTimeToSystemTime(FileInfo.ftLastWriteTime, ft) dtWrite = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond) Debug.Print "修改时间:", dtWrite End Function
'调用: FileTimeZone "c:\abc.txt" ---------------------------------------------------------------- '获得IE的版本号 Private Type DllVersionInfo cbSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformID As Long End Type Private Declare Function DllGetVersion Lib "Shlwapi.dll" (dwVersion As DllVersionInfo) As Long
Private Function GetIEVersionString() As String
Dim iever As DllVersionInfo iever.cbSize = Len(iever) Call DllGetVersion(iever) GetIEVersionString = "Internet Explorer " & iever.dwMajorVersion & "." & _ iever.dwMinorVersion & "." & iever.dwBuildNumber End Function Private Sub Command1_Click()
Debug.Print GetIEVersionString End Sub Public Function MonthDays(dtDate As Date) As Integer '返回该月总天数(如果要返回的是日期,那么下例速度快,这里再用函数转换成日期的话,速度太慢了) Select Case Month(dtDate) Case 1, 3, 5, 7, 8, 10, 12 MonthDays = 31 Case 2 MonthDays = 28 Dim i As Integer i = Year(dtDate) '闰年条件 If (i Mod 4 = 0) Then MonthDays = MonthDays + _ Abs(CInt((i Mod 100) > 0 Or (i Mod 400) = 0)) Case Else MonthDays = 30 End Select End Function Public Function MonFinalDay(dtDate As Data) As Date
'返回当月的最后一天的日期 '(如果要的结果是天数,那么还是用上例吧.它用到的函数少,除2月份,其它的值只是直接判断给出而已) MonFinalDay = DateSerial(Year(dtDate), Month(dtDate) + 1, 0) End Function ---------------------------------------------------------------------------------- '下面是些关于处理速度的有趣测试,无聊的朋友不妨看看.
'无聊作者:csdngoodnight '这是为了计时的声明
Private Declare Function timeGetTime Lib "winmm.dll" () As Long '这是第一个测试需要的声明
Private Declare Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String Private Declare Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String '大小写比较运算的速度问题:
'某些文章讲用相关的API函数将更快,UCase和LCase函数功能由msvbvm50.dll或msvbvm60.dll提供,而另两个由user32.dll提供, '我怎么也不能理解为什么自己有的不用,而去借别人的,速度还会快?! '(至于msvbvm60.dll,网上有很多资料) '主要注意For循环中代码,那才是要测试的东西 Private Sub Command1_Click() '直接用函数运算 Dim l As Long '记录开始时间 l = timeGetTime() Dim s As String Dim i As Long '为了明显体现耗时,这里用到多次循环(下同) For i = 0 To 100000 s = UCase("abcdefg") 's = UCase$("abcdefg") s = LCase(s) 's = LCase$(s) Next '显示结束时间(耗时) Debug.Print timeGetTime - l End Sub Private Sub Command2_Click()
'调用API运算 Dim l As Long l = timeGetTime() Dim s As String Dim i As Long For i = 0 To 100000 s = CharUpper("abcdefg") s = CharLower(s) Next Debug.Print timeGetTime - l End Sub '-------------------------------------------------- '使用With语句引用对象,这样写,在涉及属性较多时,确实省事,也减少了出错几率
'但速度快并不像某些人说的那么夸张,几乎是一样的.你可以把循环次数从1000增至10000再看看 '用With代价是付出了系统资源,虽然小的几乎可以忽略,引用的属性较少时,还是不用With吧 Private Sub Command3_Click() Dim l As Long l = timeGetTime() Dim i As Long For i = 0 To 1000 With Text1 .Text = "" .Width = 3000 .Text = "abc" .Width = 1215 End With Next Debug.Print timeGetTime - l End Sub Private Sub Command4_Click()
Dim l As Long l = timeGetTime() Dim i As Long For i = 0 To 1000 Text1.Text = "" Text1.Width = 3000 Text1.Text = "abc" Text1.Width = 1215 Next Debug.Print timeGetTime - l End Sub '------------------------------------------------------- '关于使用*而不是^执行简单的整数幂运算,直接用*运算速度快
'如果 a 是一个复杂的表达式,用*时,表达式就得重复写两遍,之前将表达式赋予另一个变量 Private Sub Command5_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim a As Integer, b As Integer For i = 0 To 100000 a = 2 b = a * a Next Debug.Print timeGetTime - l End Sub Private Sub Command6_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim a As Integer, b As Integer For i = 0 To 100000 a = 2 b = a ^ 2 Next Debug.Print timeGetTime - l End Sub '--------------------------------------------------------- '关于参数的传递,按址传递还是按值传递
'如果传入的值不需要返回,加上ByVal或许是有必要的,系统就不必再去寻址和复制这个值了 Private Sub Command7_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim a As Integer For i = 0 To 1000000 a = x1(1) a = x1(2) a = x1(3) a = x1(4) Next Debug.Print timeGetTime - l End Sub Private Sub Command8_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim a As Integer For i = 0 To 1000000 a = x2(1) a = x2(2) a = x2(3) a = x2(4) Next Debug.Print timeGetTime - l End Sub Function x1(ByRef i As Integer) As Integer
'ByRef:按址传递[默认,如果该字符省略] x1 = i + 2 End Function Function x2(ByVal i As Integer) As Integer
'ByVal:按值传递 x2 = i + 2 End Function '---------------------------------------------------- '检查字节是否为0
'常见到是这样写的: if 表达式 = "" then 'if len(表达式) = 0 then 的处理速度要明显快于前者(不止快1倍) Private Sub Command9_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 1000000 If Len(s) = 0 Then End If Next Debug.Print timeGetTime - l End Sub Private Sub Command10_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 1000000 If s = "" Then End If Next Debug.Print timeGetTime - l End Sub '------------------------------------------------- (待续) (续) '下列代码证明用 Move 还是非常划算的
Private Sub Command11_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 10000 Text1.Move 0, 0 ', 1000, 600 Next Debug.Print timeGetTime - l End Sub Private Sub Command12_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 10000 Text1.Left = 0 Text1.Top = 0 'Text1.Width = 1000 'Text1.Height = 600 Next Debug.Print timeGetTime - l End Sub '---------------------------------------------------------------- '关于变量声明
Private Sub Command13_Click() Dim l As Long l = timeGetTime() Dim i As Long '注意下面这一句声明(未指定类型,默认为Variant) Dim x For i = 0 To 1000000 x = i x = i Next Debug.Print timeGetTime - l End Sub Private Sub Command14_Click()
Dim l As Long l = timeGetTime() Dim i As Long '注意下面这一句声明(明确指定类型) '要注意一下,因为long型也是32位CPU的强项. Dim x As Long For i = 0 To 1000000 x = i x = i Next Debug.Print timeGetTime - l End Sub '------------------------------------------------------------------ '出于精减代码的考虑,某些人建议用 IIf 或 Switch 代替 If,下面演示两种算法的速度 '我的机器上速度大概是 6:1 '不得已时用用也就罢了,用牺牲运算速度来精简代码?什么习惯?! Private Sub Command15_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim b As Boolean Dim s As String For i = 0 To 1000000 s = IIf(b, "ok", "err") Next Debug.Print timeGetTime - l End Sub Private Sub Command16_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim b As Boolean Dim s As String For i = 0 To 1000000 If b Then s = "ok" Else s = "err" End If '真的要精简的话,不如这样精简: 'If b Then s = "ok" Else s = "err" Next Debug.Print timeGetTime - l End Sub '--------------------------------------------------------------------- '数据格式 Format 和 FormatNumber 比较,功能一样,都是保留两位小数 '如果一个工程里只偶尔格式一下也就罢了,不然还是做个选择好 '虽然速度仅有1/10左右的差别 Private Sub Command17_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 100000 s = FormatNumber(123.456, 2) Next Debug.Print timeGetTime - l End Sub Private Sub Command18_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 100000 s = Format(123.456, "0.00") Next Debug.Print timeGetTime - l End Sub '---------------------------------------------------------------------- '使用 Trim 还是Trim$ ? '前者将数据类型看作是variant 而不是 string,速度将慢3倍!(还有很多类似的函数,如 Mid/Mid$ 等等) '毕竟不是常用的,不费这个脑筋也罢 Private Sub Command19_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 100000 s = Trim$(" abc ") Next Debug.Print timeGetTime - l End Sub Private Sub Command20_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim s As String For i = 0 To 100000 s = Trim(" abc ") Next Debug.Print timeGetTime - l End Sub '------------------------------------------------------------------ '将可能多次使用的对象的属性保存到一个变量中去,处理速度不止10几倍的提升(甚至百倍,千倍,随对象不同而不同) Private Sub Command21_Click() Dim l As Long l = timeGetTime() Dim i As Long Dim s As Integer For i = 0 To 1000000 '这里是直接从对象中读取属性值 s = Text1.Width Next Debug.Print timeGetTime - l End Sub Private Sub Command22_Click()
Dim l As Long l = timeGetTime() Dim i As Long Dim s As Integer '这里先将 Text1.Width 存入变量 t 中 Dim t As Integer t = Text1.Width For i = 0 To 1000000 s = t Next Debug.Print timeGetTime - l End Sub 'ADO 连接本地mdb数据库(简单示例) '工程--->引用--->Microsoft ActiveX Data Object 2.x
'(2.x是版本号,如2.1/2.5/2.6/2.7...根据需要选择适当版本) 'csdngoodnight (E-mail:kxufeng@163.com) Option Explicit
'定义一个连接对象.通常在一个工程中只要有一个就足够了,在启动之初建立连接,而在退出时销毁
'相关细节介绍见<ADO三大对象的属性、方法、事件及常数> Dim db As Connection '定义数据集合对象 Dim WithEvents adoRS As Recordset Private Sub Form_Load() '通常在程序启动之初,先核实要打开的数据库文件是否存在,一般用Dir函数,此处略过 '此例假设在工作目录下已经存在一个:db1.mdb '该数据库仅有一个表:"表1",表1中有2个字段:"ID"和"字段1" '数据库文件存在,再测试是否损坏,要引用Microsoft Jet and Replication Objects X.X Library(JRO), '它是ADO功能的延伸,此处略过 '初始化 Set db = New Connection '确定游标引擎:adUseClient-客户端,adUseServer-服务器端(默认值) db.CursorLocation = adUseClient '用连接字符串来打开一个连接 db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & _ App.Path & "\db1.mdb;Jet OLEDB:Database Password=1234;" '如果你的数据库没有设置密码,请把连接字符串中"Jet OLEDB:Database Password=1234;"段去掉 '其中"1234"是数据库的密码 '初始化数据集合对象. Set adoRS = New Recordset '在一个已经打开连接的Connection对象(db)中使用 '语法: 'rstName.Open [varSource [, varActiveConnection [, lngCursorType [, lngLockType [, lngOptions]]]]] '详细的参数请参看后续资料,SQL语法略过 adoRS.Open "SELECT * FROM 表1", db, adOpenStatic, adLockOptimistic '-------------------------------------------------------------------------------------- '这样,我们就得到了"表1"中所有的记录,若想看看都是些什么,请把下列Do Loop循环解开 ' adoRS.MoveFirst '将指针移至首条记录 ' Do While Not adoRS.EOF '循环至末条记录 ' Debug.Print adoRS!ID, adoRS!字段1 '将字段内容列出 'Debug.Print adoRS.Fields("ID"), adoRS.Fields("字段1") '此句与上一句效果相同 ' adoRS.MoveNext '指针下移 ' Loop '-------------------------------------------------------------------------------------- '赋值给 DataGrid 表(先加载部件:Microsoft DataGrid Control 6.0 (SP5) (OLEDB)) '本例使用默认设置,如果要更好看一些的界面,请用控件的(右键菜单)"属性"和"编辑" Set DataGrid1.DataSource = adoRS '表刷新 'DataGrid1.Refresh '如果要绑定到TextBox(此例用的是数组): '绑定后,textbox仅显示首条记录,通过adoRS.MoveNext等指针操作,可以查看其它数据 '设置对应的字段名: Text1(0).DataField = "ID" Text1(1).DataField = "字段1" '......... '循环赋值 Dim oText As TextBox 'TextBox For Each oText In Me.Text1 Set oText.DataSource = adoRS Next End Sub
Private Sub Command1_Click()
'这里是添加一条记录的代码(简单示例) '假设我们用先前绑定的textbox来接收数据 '数据集插入新记录 adoRS.AddNew '将textbox的text值送到数据集 adoRS!ID = Text1(0).Text adoRS!字段1 = Text1(1).Text '将数据更新到数据库(如果数据库很大,此方法效率未必好,可在SQL语句上做做文章,比如用插入语句) adoRS.UpdateBatch adAffectAll End Sub Private Sub Command2_Click()
'删除 '先将指针移至要删除的位置,然后执行Delete adoRS.Delete '刷新表视图 adoRS.Requery Set DataGrid1.DataSource = adoRS DataGrid1.Refresh End Sub Private Sub Command3_Click() '上移一条 If adoRS.BOF Then '如果已到最首,而且有记录条,则移至首条 If adoRS.RecordCount > 0 Then adoRS.MoveFirst Else '正常时,上移一条 adoRS.MovePrevious End If End Sub Private Sub Command4_Click()
'下一条 If adoRS.EOF Then '如果已到最末,而且有记录条,则移至末条 If adoRS.RecordCount > 0 Then adoRS.MoveFirst Else '正常时,下移一条 adoRS.MoveNext End If End Sub Private Sub Command5_Click()
'第一条 If Not adoRS.BOF Then adoRS.MoveFirst End Sub Private Sub Command6_Click()
'最末 If Not adoRS.EOF Then adoRS.MoveLast End Sub '另有一例打开操作,作用相同于此例(使用时注意变量定义的作用域): Sub temp() Dim cn As New ADODB.Connection '等同于db, Dim rs As New ADODB.Recordset '等同于adoRS '这里他先设置了连接字符串,然后open cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & _ App.Path & "\db1.mdb;Jet OLEDB:Database Password=1234;" cn.Open rs.CursorLocation = adUseClient
'………… End Sub ADO三大对象的属性、方法、事件及常数（一） Connection对象 属性
属性名称 数据类型和用途
Attributes 可读写Long类型，通过两个常数之和指定是否使用保留事务（retainning transactions）。常数adXactCommitRetaining表示调用CommitTrans方法时启动一个新事务；常数adXactAbortRetaning表示调用RollbackTrans方法时启动一个新事务。默认值为0，表示不使用保留事务。 CommandTimeout 可读写Long类型，指定中止某个相关Command对象的Execute调用之前必须等待的时间。默认值为30秒。 ConnectionString 可读写String类型，提供数据提供者或服务提供者打开到数据源的连接所需要的特定信息 ConnectionTimeout 可读写Long类型，指定中止一个失败的Connection.Open方法调用之前必须等待的时间，默认值为15秒。 CursorLocation 可读写Long类型，确定是使用客户端(adUseClient)游标引擎，还是使用服务器端(adUseServer)游标引擎。默认值是adUseServer。 DefaultDatabase 可读写String类型，如果ConnectString中未指定数据库名称，就使用这里所指定的名称，对SQL Server而言，其值通常是pubs IsolationLevel 可读写Long类型，指定和其他并发事务交互时的行为或事务。见IsolationLevel常数 Mode Long类型，指定对Connection的读写权限。见Mode常数 Provider 可读写String类型，如果ConnectionString中未指定OLE DB数据或服务提供者的名称，就使用这时指定的名称。默认值是MSDASQL(Microsoft OLE DB Provider for ODBC)。 State 可读写Long类型，指定连接是处于打开状态，还是处于关闭状态或中间状态。见State常数 Version 只读String类型，返回ADO版本号。 注意：上面所列出的大多数可读写的属性，只有当连接处于关闭状态时才是可写的。
只有当用户为Connection对象用BeginTrans...CommitTrans...RollbackTrans方法定义了不遗余力，事务隔离程度的指定才真正有效。如果有多个数据库用户同时执行事务，那么应用程序中必须指定如何响应运行中的其他事务。
方法
方法 用途
BeginTrans 初始化一个事务；其后必须有CommitTrans和／或RollbackTrans相呼应 Close 关闭连接 CommitTrans 提交一个事务，以完成对数据源的永久改变（要求使用之前必须调用了BeginTrans方法) Execute 人SELECT SQL语句返回一个forward-only Recordset对象，也用来执行那些不返回Recordset语句，如INSERT、UPDATE、DELETE查询或DDL语句 Open 用连接字符串来打开一个连接 OpenSchema 返回一个Recordset对象以提供数据源的结构信息(metadata) RollbackTrans 取消一个事务，恢复对数据源做的临时性改变(要求使用之前必须调用了BeginTrans方法) 注：只有Execute、Open和OpenSchema三个方法才能接受变元参数。Execute的语法为：
cnnName.Execute strCommand,[lngRowsAffected[,lngOptions]] strCommand的值可以是SQL语句、表名、存储过程名，也可以是数据提供者所能接受的任意字符串。为了提高性能，最好为lngOptions参数指定合适的值（详见lngOptions参数用到的常数），以使提供者解释语句时不用再去判定其类型。可选参数lngRowsAffected将返回INSERT、UPDATE或DELETE查询执行以后所影响的数目。这些查询会返回一个关闭的Recordset对象。一个SELECT查询将返回lngRowsAffected值为0并且返回带有一行或多行内容的打开的forward-only Recordset。 事件
事件名称 触发时机
BeginTransComplete BeginTrans方法执行以后。 Private Sub cnnName_BeginTransComplet(ByVal TransactionLevel As Long,ByVal pError As ADODB.Error,adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) CommitTransComplete CommitTrans方法执行以后 Private Sub Connection1_CommitTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) ConnectComplete 成功建立到数据源的Connection之后 Private Sub Connection1_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) Disconnect Connection关闭之后 Private Sub Connection1_Disconnect(adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) ExecuteComplete 完成Connection.Execute或Command.Execute之时 Private Sub Connection1_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection) InfoMessage 一个Error对象被添加到ADODB.Connectio.Error集合之时 Private Sub Connection1_InfoMessage(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) RollbackTransComplete RollbackTrans方法执行之后 Private Sub Connection1_RollbackTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) WillConnect 即将调用Connection.Open方法之时 Private Sub Connection1_WillConnect(ConnectionString As String, UserID As String, Password As String, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection) WillExecute 即将调用Connection.Execute或Command.Execute方法之时 Private Sub Connection1_WillExecute(Source As String, CursorType As ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection) 注：其中的adStatus参数所用到的常数的名称和含义详见adStatus所用的常数
常数
IsolationLevel常数
常数 含义
adXactCursorStability 只允许读其他事务已提交的改变（默认值） adXactBrowse 允许读其他事务未提交的改变 adXactChaos 本事务不会覆盖其他位于更高隔离程度的事务所做的改变 adXactIsolated 所有事务相互独立 adXactReadCommitted 等同于adXactCursorStability adXactReadUncommitted 等同于adXactBrowse adXactRepeatableRead 禁止读其他事务的改变 adXactSerializable 等同于adXactIsolated adXactUnspecified 不能确定提供者的事务隔离程度 Mode常数
常数 含义
adModeUnknown 未指定数据源的连接许可权（默认值） adModeRead 连接是只读的 adModeReadWrite 连接是可读写的 adModeShareDenyNone 不拒绝其他用户的读写访问(Jet OLE DB Provider的默认值) adModeShareDenyRead 拒绝其他用户打开到数据源的读连接 adModeShareDenyWrite 拒绝其他用户打开到数据源的写连接 adModeShareExclusive 以独占方式打开数据源 adModeWrite 连接是只写的 State常数
常数 含义
adStateClosed Connection(或其他对象)是关闭的(默认值) adStateConnecting 正在连接数据源的状态 adStateExecuting Connection或Command对象的Execute方法已被调用 adStateFetching 返回行(row)到Recordset对象 adStateOpen Connection(或其他对象)是打开的(活动的) Execute方法中lngOption参数用到的常数
Command类型常数 含义
adCmdUnknown Command类型未定（默认值），由数据提供者去判别Command语法 adCmdFile Command是和对象类型相应的文件名称 adCmdStoredProc Command是存储过程名称 adCmdTable Command是能产生内部SELECT * FROM TableName查询的表名称 adCmdTableDirect Command是能直接从表中获取行内容的表名称 adCmdText Command是一条SQL语句 ADODB事件处理子过程参数adStatus所用的常数
常数 含义
adStatusCancel 操作被用户取消 adStatusCnatDeny 操作不能拒绝其他用户对数据源的访问 adStatusErrorsOccurred 操作导致错误并已送到Errors集合中 adStatusOK 操作成功 adStatusUnWantedEvent 操作过程中一个未预料到的事件被激活 ADO三大对象的属性、方法、事件及常数（二） Command对象 Command对象的主要目的是执行参数化的存储过程。其形式要么是临时准备(prepared），要么是持久的预编译（precompiled）过的SQL语句。如果想（存储）一个或多个查询以供在同一Connection上多次执行，Command对象也是很有用的。当想创建Recordset时，一种高效的方法是绕过Command对象而采用Recordset.Open方法。
属性
属性名称 数据类型和用途
ActiveConnection 指针类型，指向Command所关联的Connection对象。对于现存的已打开连接，可使用Set cmmName.ActiveConnection=cnnName。另外，也可以不用相关Connection对象名称而使用有效的连接字符串去创建一个新的连接。默认值为Null。 CommandText 可读写String类型。为ActiveConnection指定一条SQL语句、表名、存储过程名或提供者能接受的任意字符串。CommandType属性的值决定了CommandText属性值的格式。默认值为空字符串："" CommandTimeout 可读写Long类型，指定中止一个Command.Execute调用之前必须等待的时间。这时的值优先于Connection.ComandTimeout中的设定值。默认值为30秒。 CommandType 可读写Long类型，指定数据提供者该如何解释CommandText属性值。CommandType等效于Connection.Execute方法中的可选参数lngOption。详见CommandType所用到的常数。默认值为adCmdUnkown. Name 可读写String类型，指定Command的名称。 Prepared 可读写Boolean类型，判断数据源是否把CommandText中的SQL语句编译为prepared statement（一种临时性存储过程）。prepared statement仅存活于Command的ActiveConnection生命周期中。许多客户／服务器RDBMS，包括SQL SERVER，都支持prepared statement。如果数据源不支持prepared statement,则把该属性设为True，将导致一个自陷错误。 State 可读写Long类型，指定Commnad状态。见State常数。 注意：最好每次都为CommandType指定的一个合适的常数值，否则会降低系统运行的效率。
方法
方法 用途
Createparameter 在执行该方法之前，必须首先声明一个ADODB.Parameter对象。调用语法为： cmmName.CreateParameter [strName[,lngType[,lngDirection[,lngSize[,varValue]]]]] Execute 调用语法同Connection.Execute大致相同。 常数
State常数
常数 含义
adStateClosed Connection(或其他对象)是关闭的(默认值) adStateConnecting 正在连接数据源的状态 adStateExecuting Connection或Command对象的Execute方法已被调用 adStateFetching 返回行(row)到Recordset对象 adStateOpen Connection(或其他对象)是打开的(活动的) CommandType所用到的常数
Command类型常数 含义
adCmdUnknown Command类型未定（默认值），由数据提供者去判别Command语法 adCmdFile Command是和对象类型相应的文件名称 adCmdStoredProc Command是存储过程名称 adCmdTable Command是能产生内部SELECT * FROM TableName查询的表名称 adCmdTableDirect Command是能直接从表中获取行内容的表名称 adCmdText Command是一条SQL语句 ADO三大对象的属性、方法、事件及常数（三） Recordset对象 属性
属性名称 数据类型和用途
AbsolutePage 可读写Long类型，要么是设置或返回当前记录所处的页面序号，要么是一个PositionEnum常数，见AbsolutePage用到的常数。在获取或设置AbsolutePage的值之前，必须先设定PageSize的值。AbsolutePage是从1开始计数的。如果当前记录位于第一页时，AbsolutePage的返回值为1，对AbsolutePage设置将使当前记录指针指向指定页的第一条记录。 AbsolutePosition* 可读写的Long类型（从1开始计数），设置或返回当前记录年处的位置。AbsolutePosition的最大取值是RecordCount属性的值。 ActiveCommand 可读写的String类型，Recordset所关联的先前打开的Command对象名称 ActiveConnection 指针类型，指向Recordset所关联的先前打开的Connection对象，或指向一条完整有效的ConnectionString串值。 BOF* 只读Boolean类型，若为True，表明记录指针已位于Recordset第一条记录之前，并且没有了当前记录 Bookmark* 可读写Variant类型，返回对特定记录的引用或使用一个Bookmark值使记录指针指向特定记录 CacheSize* 可读写Long类型，指定本地Cache中所存的记录条数，最小(默认值)为1。若增加了CacheSize的值，则在流动Recordset以获取更多记录时，能减少与服务器的通信次数。 CursorLocation 可读写Long类型，指定可流动游标的位置，即CursorType是位于客户端还是位于服务器端，见CursorLocation用到的常数。默认值是使用OLE DB数据源提供的游标。 CusrsorType* 可读写Long类型，指定Recordset游标的类型，见CursorType用到的常数，默认值是forward-only游标 DataMember 指针类型，指向关联的DataEnvironment.Command对象 DataSource 指针类型，指向关联的DataEnvironment.Connection对象 EditMode* 只读Long类型，返回Recordset的编辑状态，见EditMode用到的常数 EOF* 只读Boolean类型，若为True，表明记录指针已超出Recordset的最后一条记录，并且没有了当前记录。 Filter* 可读写Variant类型，要么是一条件表达式（一条有效的SQL WHERE子句但又不出现保留字WHERE），要么是指向特定记录的Bookmark数组，要么是一个Filter常数，详见Filter用到的常数。 LockType* 可读写Long类型，指定打开Recordset所使用的记录锁定方法。默认值是只读，对应于forward-only游标的只读特性。见LockType属性用到的常数。 MarshalOptions 可读写Long类型，指定客户端改动后，应返回哪个记录集合，此属性仅适合于不常见的ADOR.Recordset对象，此对象是RDS.ADOR.Recordset对象成员之一。 MaxRecords* 可读写Long类型，指定SELECT查询或存储过程返回的最大记录条数，默认值为0，即全部返回 PageCount 只读Long类型，返回Recordset所有的页数，必须设定了PageSize的值，PageCount的返回值才是真正有意义的。如果Recordset不支持PageCount属性，则返回值为-1 PageSize 可读写Long类型，设置或返回一个逻辑页所包含的记录条数。使用逻辑页可把大的Recordset分解为多个易处理的小部分。通常的做法是把PageSize设为DataGrid、MsFlexGrid或层次型的FlexGrid控件所能显示的记录条数。PageSize和锁定Jet(2k)或锁定SQL Server(6.5版及更早版本,2k;7.0版，8k)数据库时用到的表页面大小无关 PersistFormat 可读写Long类型，设置或返回由调用Save方法所创建的Recordset文件的格式。当前仅有一个值adPersistADTG(默认格式：Advanced Data TableGram) RecordCount* 只读Long类型，如果Recordset支持近似定位或支持书签，则返回带可流动游标的Recordset所含有的记录数；如果不支持，必须使用MoveLast方法以取得确实覆盖了所有记录的准确的RecordCount数值。如果forward-only类型Recordset有一条或多条记录，Recordset返回-1(True),任何类型的空的Recordset都将返回0(False) Sort* 可读写String类型，包含一条不含保留字ORDER BY的SQL ORDERY BY子句，用以指定Recordset的排序方式 Source* 可读写String类型，可以是SQL语句、表名、存储过程名或相关Command对象名。如果提供了Command对象名，则Source将返回Command.CommandText的值。利用Open方法的参数lngOptions可以指定提供给Source值的类型 State 可读写Long类型，为对象状态常数之一。见State常数 Status 只读Long类型，表明对Recordset进行批处理或其他多记录(bulk)操作后的状态。见Status属性用到的常数 注意：上表所列属性是ADODB.Recordset对象的标准属性，即那些被关系数据库的大多数通用OLE DB数据提供者所支持的属性。带星号的属性表示它与DAO.Recordset或rdoResultset对象的相应属性完全一样或很接近。
方法
方法 用途
AddNew* 向可更新的Recordset添加一条新记录。调用语法为rstName.AddNew[{varField|avarFields},{varValue|avarValuese}],其中varField是单个字段名，avarFields是字段名数组。varValue是单个字段值，avarValue是由avarFields指定字段的值所组成的数组。调用Update方法则把新记录加到数据库的表中。如果向主关键字不是第一个字段的Recordset中添加记录，则必须在AddNew方法中指定主关键字的名称和值 Cancel 取消异步查询的执行，中止存储过程或复合SQL语句创建多个Recordset，调用语法为rstName.Cancel CancelBatch* 取消LockEdit值为BatchOptimistic的Recordset的即将生效的批量更新操作，调用语法为：rstName.CancelBatch [lngAffectRecords],可选参数lngAffectRecords的取值见lngAffectRecords用到的常数 Clone 复制一个带有独立记录指针的Recordset对象，调用语法为：Set rstDupe=rstName.Clone() Close 关闭Recordset对象，以后可以重新设Recordset的属性并使用Open方法来再度访问Recordset 。调用语法为:rstName.Close Delete* 如果Recordset的LockEdit属性值未设为adLockBatchOptimistic，立刻从Recordset和相应表中删除当前记录 Find 寻找满足指定条件的记录。调用语法为：rstName.Find strCriteria [,lngSkipRecords, lngSearchDirection [,lngStart]],其中strCriteria是不含WHERE关键字的SQL WHERE子句，可选参数lngSkipRecords是应用Find前所跳过的记录数目，lngDirection指定查找方向(adSearchForward,和adSearchBackward,其中adSearchForward是默认值),可选参数lngStart指定了从哪儿开始查找，其值要么是一个Bookmark值，要么是Bookmark常数，见varStart参数用到的Bookmark常数。 GetRows 返回一个二维Variant数组（行、列），调用语法为avarname=rstName.GetRows(lngRows [,varStart[,{strFieldName|lngFieldIndex|avarFieldNames|avarFieldIndexes}]],其中lngRows是返回记录行数，varStart指定从哪儿开始查找，其值要么是一个Bookmark值，要么是Bookmark常数，见varStart参数用到的Bookmark常数。第三个参数可以是单个列（字段）的名称或索引，也可以是多个列名称或索引组成的Variant数组。如果不指定第三个参数，GetRows返回Recordset中所有列。 GetString 默认情况下，返回指定数目记录的String串值，记录间由返回代码分隔。记录内由tab分隔。调用语法为： strClip=rstname.GetString(lngRows,[, strCloumnDelimiter[,strRowDelimiter,[strNullExpr]]])。其中lngRows为返回记录行数，strColumnDelimiter为可选的列分隔符(vbTab是默认值),strRowDelimiter是可选的行分隔符(vbCr是默认值)，strNullExpr是可选参数，用于碰到Null值时的替代值（默认值是空字符串）。GetString的主要用途是通过把控件的Clip属性设为strClip来处理MSFlexGrid或MSHFlexGrid控件 Move* 从当前记录移动记录指针。调用语法为：rstName.Move lngNumRecords [, varStart],其中lngNumRecords是要跳过的记录数，可选选参数varStart指定从哪开始移动。其值要么是一个Bookmark值，要么是Bookmark常数，见varStart参数用到的Bookmark常数。 MoveFirst* 移动记录指针到第一条记录，调用语法为：rstName.MoveFirst MoveLast* 移动记录指针到最后一条记录，调用语法为：rstName.MoveLast MoveNext 移动记录指针到下一条记录，调用语法为：rstName.MoveNext。它是能用于forward-only Recordset的唯一Move方法 MovePrevious* 移动记录指针到前一条记录，调用语法为：rstName.MovePrevious NextRecordset 返回另外的Recordset,它通常由能产生多个Recordset的复合SQL语句(如SELECT * FROM orders;SELECT * FROM customers)或存储过程来创建。调用语法为Next=rstName.NextRecordset [(lngRecordsAffected)],其中可选参数lngRecordsAffected指定返回到rstNext中去的记录数目。如果已不存在Recordset，rstNext被设为Nothing Open 在一个活动Command或Connection对象上打开一个Recordset，调用语法为：rstName.Open [varSource [, varActiveConnection [, lngCursorType [, lngLockType [, lngOptions]]]]]。这些参数都是可选的， Requery 重新从表中获取Recordset的内容，等效于Close后再Open。它是一个资源集中型操作。语法为：rstName.Requery Resync* 重新从表中获取部分Recordset内容。调用语法为rstName.Resync [lngAffectRecords],其中lngAffectRecords的取值见lngAffectRecords用到的常数。如果把该参数设为adAffectCurrent或adAffectGroup，则比adAffectAll(默认值)所耗的资源要少。 Save 创建包含Recordset永久性拷贝的文件。调用语法为rstName.Save strFileName。其中strFileName为路径和文件名。通常用.rst作为文件的扩展名。 Supports 如果数据提供者支持指定的游标相关的方法，则返回True，否则返回为False。调用语法为Supported=rstname.Supports (lngCursorOptions).关于lngCursorOptions,见Supports方法用到的常数。 Update* 使对Recordset的修改对底层数据源中的表生效。对于批量操作，Update方法只使修改对本地(Cached)Recordset生效。调用语法为rstName.Update UpdateBatch* 合对指量类型的Recordset(LockType属性值为adBatchOptimistic,CursorType属性值为adOpenKeyset或adOpenStatic)所做的修改对底层数据源中的表生效。调用语法为rstName.UpdateBatch [lngAffectRecords],其中lngAffectRecords的取值见lngAffectrecords用到的常数。 注：ADODB.Recordset对象不支持Edit方法。为了改变ADODB.Recordset对象当前记录的一个或多个字段的值，可以先使用rstName.Fields(n).Value=varValue把相应字段的值改为所需要的值，而后执行rstName.Update即可。
事件
事件名称 触发时机
EndOfRecordset 记录指针试图移到最后一条记录之外时 FieldchangeComplete 字段值的改变完成之后 MoveComplete Move或Move...方法执行之后 RecordsChangeComplete 对单个记录编辑完成以后 RecordsetChangeComplete 缓存中的改变对底层表生效之后 WillChangField 对字段值改变之前 WillChangeRecord 对单个记录改变之前 WillChangeRecordset 缓存中的改变对底层表生效之前 WillMove Move或Move...方法执行之前 注：事件处理模块的函数头几乎都用到了adReason参数。该参数的取值见adReason参数用到的常数。
常数
AbsolutePage属性用到的常数
常数 含义
adPosUnknown 数据提供者不支持页面，Recordset为空，或数据提供者不能确定页码。 adPosBOF 记录指针定位于文件开头（BOF属性值为True） adPosEOF 记录指针定位于文件结尾（EOF属性值为True） CursorLocation属性用到的常数
常数 含义
adUseClient 使用客户端游标库提供的游标。ADODB.Recordset要求客户端游标 adUseServer 使用数据源提供的游标，通常（但非绝对）位于服务器上（默认值） CursorType属性用到的常数
常数 含义
adOpenForwardonly 提供单向移动游标和只读Recordset（默认值） adOpenDynamic 提供可滚动游标，可显示其他用户对Recordset所做的改动（包括添加新记录） adOpenKeyset 提供可滚动游标，只隐藏其他用户所做的改动，类似于dynaset类型的DAO.Recordset adOpenStatic 提供一个位于Recordset静态拷贝上的可滚动游标，类似于snapshot类型的DAO.Recordset，但多了可更新特性 EditMode属性用到的常数
常数 含义
adEditNone 无正在进行的编辑操作(默认值) adEditAdd 临时添加一条记录，但尚未存入数据库的表中 adEditInProgress 当前记录中的数据已经改动，但尚未存入数据库的表中 Filter属性用到的常数
常数 含义
adFilterNone 除去已有的过滤器，显示Recordset中的所有记录（等效于把Filter属性置为空串，默认值） adfilterAffectedRecords 只显示上次CancelBatch、Delete、Resync或UpdateBatch方法执行后所影响的记录 adFilterFetchedRecords 只当前Cache中的记录，记录条数由CacheSize来确定 adFilterPendingRecords 只显示已改动但尚未被数据源处理的记录（仅适用于批量更新模式） LockType属性用到的常数
常数 含义
adLockRecordOnly 指定只读访问（默认值） adLockBatchOptimistic 使用批量更新模式而不是默认的立即更新模式 adLockOptimistic 使用乐观锁（仅在更新过程中才锁定记录或页面） adLockPessimistic 使用悲观锁（编辑或更新整个过程中均锁定记录或页面） State常数
常数 含义
adStateClosed Connection(或其他对象)是关闭的(默认值) adStateConnecting 正在连接数据源的状态 adStateExecuting Connection或Command对象的Execute方法已被调用 adStateFetching 返回行(row)到Recordset对象 adStateOpen Connection(或其他对象)是打开的(活动的) Status属性用到的常数(仅适用于Batch或Bulk Recordset操作) 常数 含义
adRecOK 成功更新 adRecNew 成功添加 adRecModified 成功修改 adRecDeleted 成功删除 adRecUnmodified 无改动 adRecInvalid 未保存：Bookmark属性无效 adRecMultipleChanges 未保存：保存会影响其他记录 adRecPendingChanges 未保存：记录引用了一个等待插入操作 adRecCanceled 未保存：操作被取消 adRecCantRelease 未保存：现有记录值阻止了保存 adRecConcurrencyViolation 未保存：乐观并发锁发生了问题 adRecIntegrityViolation 未保存：操作会影响一致性 adRecMaxChangesExceeded 未保存：存在太多的等待改动 adRecObjectOpen 未保存：打开存贮对象发生冲突 adRecOutofMemory 未保存：内存不足 adRecPermissionDenied 未保存：用户权限不够 adRecSchemaViolation 未保存：记录的结构不符合数据库中的定义 adRecDBDeleted 未保存或删除：记录已被删除 lngAffectRecords参数用到的常数
Command类型常数 含义
adAffectAll 包括Recordset对象的所有记录，那些被Filter属性过滤隐藏的记录也计算在内（默认值） adAffectCurrent 只包括当前记录 adAffectGroup 只包括那些符合当前Filter条件的记录 varStart参数用到的Bookmark常数
常数 含义
adBookmarkCurrent 从当前记录开始（默认值） adBookmarkFirst 从第一条记录开始 adBookmarkLast 从最后一条记录开始 Supports方法用到的常数
常数 含义
adAddNew 调用AddNew方法 adApproxPosition 设置和得到Absoluteposition和AbsolutePage属性值 adBookmark 设置和得到Bookmark属性值 adDelete 调用Delete方法 adHoldRecords 获取另外的记录或改变获取记录指针的位置，但不提交未确定的改变 adMovePrevious 调用GetRows,Move,MoveFirst和MovePrevious方法（表明是一个双向可滚动游标） adResync 调用Resync方法 adUpdate 调用Update方法 adUpdateBatch 调用UpdateBatch和CancelBatch方法 adReason参数用到的常数
常数 含义
AdRsnAddNew 调用了AddNew方法 AdRsnClose 调用了Close方法 AdRsnDelete 调用了Delete方法 AdRsnFirstChange 第一次对记录字段值做了修改 AdRsnMove 调用了Move方法 AdRsnMoveFirst 调用了MoveFirst方法 AdRsnMoveLast 调用了MoveLast方法 AdRsnMovePrevious 调用了MovePrevious方法 AdRsnRequery 调用了Requery方法 AdRsnResync 调用了Resync方法 AdRsnUndoAddNew AddNew操作被用户取消 AdRsnUndoDelete Delete操作被用户取消 AdRsnUndoUpdate Update操作被用户取消 AdRsnUpdate 调用了Update方法 本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/fxj331072/archive/2005/12/09/547823.aspx
|
|
|
