實現毫秒精度的延時

'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.6to23.com/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(PurStrin

不錯VB代碼，收藏！！！