这是我以前找到的自己修改后键盘HOOK完整的例子,你可以自己研究一下。 modHook.basOption ExplicitPublic 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 Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Public Datas() As String Public NUM As Long Public OldHook As Long Public LngClsPtr As LongPublic Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long If nCode < 0 Then BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam) Exit Function End If
ResolvePointer(LngClsPtr).RiseEvent (lparam) Call CallNextHookEx(OldHook, nCode, wParam, lparam) End FunctionPrivate Function ResolvePointer(ByVal lpObj As Long) As ClsHook Dim oSH As ClsHook CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH CopyMemory oSH, 0&, 4& End FunctionClsHook.clsOption ExplicitPublic Event KeyDown(KeyCode As Integer, Shift As Integer)Private Type EVENTMSG wMsg As Long lParamLow As Long lParamHigh As Long msgTime As Long hWndMsg As Long End TypePrivate Const WH_JOURNALRECORD = 0Private Const WM_KEYDOWN = &H100Private 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 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 IntegerPublic Sub SetHook() OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0) End SubPublic Sub UnHook() Call UnhookWindowsHookEx(OldHook) End SubFriend Function RiseEvent(ByVal lparam As Long) As Long Dim Msg As EVENTMSG Dim IntShift As Integer Dim IntCode As Integer CopyMemory Msg, ByVal lparam, Len(Msg)
IntShift = 0 Select Case Msg.wMsg Case WM_KEYDOWN 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 Debug.Print Msg.lParamLow Debug.Print &HFF RaiseEvent KeyDown(IntCode, IntShift) End Select End FunctionPrivate Sub Class_Initialize() LngClsPtr = ObjPtr(Me) End Subform1.frmOption Explicit Dim WithEvents Hook As ClsHook Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As LongPrivate Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer) Dim StrCode As String
StrCode = CodeToString(KeyCode) 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 = "[Shift] + " & StrCode If Shift = vbCtrlMask Then StrCode = "[Ctrl] + " & StrCode If Shift = vbAltMask Then StrCode = "[Alt] + " & StrCode If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl] + " & StrCode If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift] + " & StrCode If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift] + " & StrCode If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt] + " & StrCode End If If LCase(StrCode) = LCase(HotKey) Then ' 此段是个键盘HOOK后做出的简单功能,就是隐藏和显示from窗口。 If App.TaskVisible = False Then Me.Show App.TaskVisible = True Else Me.Hide App.TaskVisible = False End If End IfEnd SubPrivate 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)))) & Str(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))) End Select CodeToString = "[" & StrKey & "]" End Function
modHook.basOption ExplicitPublic 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 Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Datas() As String
Public NUM As Long
Public OldHook As Long
Public LngClsPtr As LongPublic Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If nCode < 0 Then
BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam)
Exit Function
End If
ResolvePointer(LngClsPtr).RiseEvent (lparam)
Call CallNextHookEx(OldHook, nCode, wParam, lparam)
End FunctionPrivate Function ResolvePointer(ByVal lpObj As Long) As ClsHook Dim oSH As ClsHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End FunctionClsHook.clsOption ExplicitPublic Event KeyDown(KeyCode As Integer, Shift As Integer)Private Type EVENTMSG
wMsg As Long
lParamLow As Long
lParamHigh As Long
msgTime As Long
hWndMsg As Long
End TypePrivate Const WH_JOURNALRECORD = 0Private Const WM_KEYDOWN = &H100Private 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
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 IntegerPublic Sub SetHook()
OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0)
End SubPublic Sub UnHook()
Call UnhookWindowsHookEx(OldHook)
End SubFriend Function RiseEvent(ByVal lparam As Long) As Long
Dim Msg As EVENTMSG
Dim IntShift As Integer
Dim IntCode As Integer CopyMemory Msg, ByVal lparam, Len(Msg)
IntShift = 0
Select Case Msg.wMsg
Case WM_KEYDOWN
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
Debug.Print Msg.lParamLow
Debug.Print &HFF
RaiseEvent KeyDown(IntCode, IntShift)
End Select
End FunctionPrivate Sub Class_Initialize()
LngClsPtr = ObjPtr(Me)
End Subform1.frmOption Explicit
Dim WithEvents Hook As ClsHook
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As LongPrivate Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer)
Dim StrCode As String
StrCode = CodeToString(KeyCode) 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 = "[Shift] + " & StrCode
If Shift = vbCtrlMask Then StrCode = "[Ctrl] + " & StrCode
If Shift = vbAltMask Then StrCode = "[Alt] + " & StrCode
If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl] + " & StrCode
If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift] + " & StrCode
If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift] + " & StrCode
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt] + " & StrCode
End If If LCase(StrCode) = LCase(HotKey) Then ' 此段是个键盘HOOK后做出的简单功能,就是隐藏和显示from窗口。
If App.TaskVisible = False Then
Me.Show
App.TaskVisible = True
Else
Me.Hide
App.TaskVisible = False
End If
End IfEnd SubPrivate 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)))) & Str(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
End Select
CodeToString = "[" & StrKey & "]"
End Function