實現毫秒精度的延時
'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(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.bssoft.com.cn/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方法