最近需要用vb寫鉤子程式，捕獲所有鍵盤案件資訊，從如下地址獲得了大致的方法：http://blog.sina.com.cn/s/blog_69b6a7c60100uuhf.html
大致如下：
程式原始碼：
（1）FrmHook原始碼
Option Explicit
Dim WithEvents Hook As ClsHook '創建一個需要事件支持的Hook為模塊ClsHook
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
'根據指定的映射型別，執行不同的掃描碼和字符轉換
'
' uCode Long，欲轉換的源字符或代碼
' uMapType Long，控制映射型別，如下所示
' 0 —— uCode是個虛擬鍵碼?函式回傳相應的掃描碼
' 1 —— uCode是個掃描碼?函式回傳相應的虛擬鍵碼
' 2—— uCode是個虛擬鍵碼。函式回傳相應的ASCII值（未加Shift組合鍵）。針對死鍵，高位設為1。如果出錯，回傳NULL
' dwhkl Long，鍵盤布局的句柄
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
'取得一個句柄，描述指定應用程式的鍵盤布局
' dwLayout ，//欲檢查的執行緒的識別符號
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'獲取與指定視窗關聯在一起的一個行程和執行緒識別符號
' lpdwProcessId Long，指定一個變數，用于裝載擁有那個視窗的一個行程的識別符號
' hwnd Long，指定視窗句柄
Private Sub Form_Load()
Set Hook = New ClsHook
Hook.SetHook
'App.TaskVisible = False
Me.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
Hook.UnHook
Set Hook = Nothing
End Sub
Private Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer) '鉤子的KeyDown事件，在模塊中我們自己定義的事件KeyDown
Dim StrCode As String
StrCode = CodeToString(KeyCode)
'判斷Shift
If StrCode = "[Shift]" Or StrCode = "[Alt]" Or StrCode = "[Ctrl]" Then
If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt]"
Else
If Shift = vbShiftMask Then StrCode = StrCode & " + [Shift]"
If Shift = vbCtrlMask Then StrCode = StrCode & " + [Ctrl]"
If Shift = vbAltMask Then StrCode = StrCode & " + [Alt]"
If Shift = vbAltMask + vbCtrlMask Then StrCode = StrCode & " + [Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = StrCode & " + [Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = StrCode & " + [Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = StrCode & " + [Ctrl + Shift +Alt]"
End If
'熱鍵Ctrl+J，呼出視窗
If StrCode = "[j] + [Ctrl]" Then
Me.Show
App.TaskVisible = True
End If
Text1.Text = Text1.Text & Now & "------" & StrCode & vbCrLf
End Sub
'把按鍵碼換為String
Private Function CodeToString(nCode As Integer) As String
Dim StrKey As String
Select Case nCode
Case vbKeyBack: StrKey = "BackSpace"
Case vbKeyTab: StrKey = "Tab"
Case vbKeyClear: StrKey = "Clear"
Case vbKeyReturn: StrKey = "Enter"
Case vbKeyShift: StrKey = "Shift"
Case vbKeyControl: StrKey = "Ctrl"
Case vbKeyMenu: StrKey = "Alt"
Case vbKeyPause: StrKey = "Pause"
Case vbKeyCapital: StrKey = "CapsLock"
Case vbKeyEscape: StrKey = "ESC"
Case vbKeySpace: StrKey = "SPACEBAR"
Case vbKeyPageUp: StrKey = "PAGE UP"
Case vbKeyPageDown: StrKey = "PAGE DOWN"
Case vbKeyEnd: StrKey = "END"
Case vbKeyHome: StrKey = "HOME"
Case vbKeyLeft: StrKey = "LEFT ARROW"
Case vbKeyUp: StrKey = "UP ARROW"
Case vbKeyRight: StrKey = "RIGHT ARROW"
Case vbKeyDown: StrKey = "DOWN ARROW"
Case vbKeySelect: StrKey = "SELECT"
Case vbKeyPrint: StrKey = "PRINT SCREEN"
Case vbKeyExecute: StrKey = "EXECUTE"
Case vbKeySnapshot: StrKey = "SNAPSHOT"
Case vbKeyInsert: StrKey = "INS"
Case vbKeyDelete: StrKey = "DEL"
Case vbKeyHelp: StrKey = "HELP"
Case vbKeyNumlock: StrKey = "NUM LOCK"
Case vbKey0 To vbKey9: StrKey = Chr$(nCode)
Case vbKeyA To vbKeyZ: StrKey = LCase(Chr$(nCode)) 'MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
Case vbKeyF1 To vbKeyF16: StrKey = "F" & CStr(nCode - 111)
Case vbKeyNumpad0 To vbKeyNumpad9: StrKey = "Numpad " & CStr(nCode - 96)
Case vbKeyMultiply: StrKey = "Numpad {*}"
Case vbKeyAdd: StrKey = "Numpad {+}"
Case vbKeySeparator: StrKey = "Numpad {ENTER}"
Case vbKeySubtract: StrKey = "Numpad {-}"
Case vbKeyDecimal: StrKey = "Numpad {.}"
Case vbKeyDivide: StrKey = "Numpad {/}"
Case Else
StrKey = Chr$(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
End Select
CodeToString = "[" & StrKey & "]"
End Function
Private Sub text1_Change()
Text1.SelStart = Len(Text1.Text)
End Sub
（2）ModHook原始碼
Option Explicit
Public Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Public OldHook As Long '全域變數OldHook存盤鉤子句柄
Public LngClsPtr As Long '保存物件地址
'回呼函式
Public Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If nCode < 0 Then '如果nCode小于0，上次就說過嘍，小于0代表沒有攔截到鍵盤訊息;當nCode為0的時候，所有的鍵盤訊息都將被攔截，
BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam) 'wParam為訊息的種類（種類知道吧？KeyDown ……）lparam存盤了攔截到的訊息；沒有攔截到訊息只好呼叫下個鉤子
Exit Function
End If
ResolvePointer(LngClsPtr).RiseEvent (lparam) '得到訊息的地址
'處理過后一定要將訊息歸還給系統，難免還有別人要這個訊息呢？
Call CallNextHookEx(OldHook, nCode, wParam, lparam)
End Function
'得到物件的地址
Private Function ResolvePointer(ByVal lpObj As Long) As ClsHook
Dim oSH As ClsHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End Function
（3）ClsHook原始碼：
Option Explicit '宣告,在VB中，開頭使用宣告可以減少很多的錯誤
Public Event KeyDown(KeyCode As Integer, Shift As Integer) '自定義事件 KeyDown
Private Type EVENTMSG '定義事件訊息的型別
wMsg As Long '訊息
lParamLow As Long
lParamHigh As Long
msgTime As Long '訊息時間
hWndMsg As Long '訊息句柄
End Type
'Private Const WH_GETMESSAGE As Long = 3
Private Const WH_JOURNALRECORD = 0
Private Const WM_KEYDOWN = &H100
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long 'dwThreadId監控代碼,0為全域鉤子
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Public Sub SetHook()
OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0)
End Sub
Public Sub UnHook()
Call UnhookWindowsHookEx(OldHook)
End Sub
Friend Function RiseEvent(ByVal lparam As Long) As Long
Dim Msg As EVENTMSG
Dim IntShift As Integer 'Shift
Dim IntCode As Integer 'KeyCode
CopyMemory Msg, ByVal lparam, Len(Msg) '利用指標技術將訊息從lparam中的資料拷貝到Msg的地址中,簡單的說就是把lparam的資料賦值給Msg
IntShift = 0
Select Case Msg.wMsg '檢查訊息狀態
Case WM_KEYDOWN '如果訊息的事件為KeyDown（鍵盤按下）
'得到Shift,Ctrl,Alt的按鍵狀態
If GetAsyncKeyState(vbKeyShift) Then IntShift = (IntShift Or 1)
If GetAsyncKeyState(vbKeyControl) Then IntShift = (IntShift Or 2)
If GetAsyncKeyState(vbKeyMenu) Then IntShift = (IntShift Or 4)
IntCode = Msg.lParamLow And &HFF '得到KeyCode（及按鍵碼）
RaiseEvent KeyDown(IntCode, IntShift) 'RaiseEvent 引發模塊(ClsHook)中宣告的事件 KeyDown
End Select
End Function
Private Sub Class_Initialize() '初始化類
LngClsPtr = ObjPtr(Me) 'ObjPtr，回傳物件的地址，將本類的存盤地址回傳給變數LngClsPtr
End Sub
嘗試了下可以運行，但是有個問題，就是鎖屏后，就沒有任何反應了，任何的鍵都不觸發Hook_KeyDown了，請大牛看看什么問題？？
uj5u.com熱心網友回復：
是的，這個只能對當前桌面會話有效。鎖定作業站的原理就是切換到另一個桌面會話中。我們知道，Windows Server終端服務允許同時多個人在同一系統內使用各自的桌面而互不干擾，試想，如果不同的桌面會話可以回應彼此的鍵盤操作，豈不亂套了。
uj5u.com熱心網友回復：
http://download.csdn.net/detail/veron_04/1860777http://download.csdn.net/detail/veron_04/3629729
http://download.csdn.net/detail/veron_04/3400339
uj5u.com熱心網友回復：
那如果是想都能回應或者彼此不干擾的回應呢？如何操作呢？
uj5u.com熱心網友回復：
不是不知道該如何捕獲，是能捕獲了，只是鎖屏了以后就不起效果了。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/147817.html
標籤：API
下一篇：VB與資料庫的基本應用問題