算了,把代码给你cSystemHook.clsOption ExplicitPublic Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Public Event KeyDown(KeyCode As Integer, Shift As Integer) Public Event KeyUp(KeyCode As Integer, Shift As Integer) Public Event SystemKeyDown(KeyCode As Integer) Public Event SystemKeyUp(KeyCode As Integer)Private Declare Function SetWindowsHookEx Lib "user32" 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" (ByVal hHook As Long) As Long Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)Private Const WM_KEYDOWN = &H100 Private Const WM_KEYUP = &H101 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 Const WM_MBUTTONDOWN = &H207 Private Const WM_MBUTTONUP = &H208 Private Const WM_MBUTTONDBLCLK = &H209 Private Const WM_MOUSEWHEEL = &H20A Private Const WM_SYSTEMKEYDOWN = &H104 Private Const WM_SYSTEMKEYUP = &H105Private Const WH_JOURNALRECORD = 0 Private Const WH_GETMESSAGE = 3Private Type EVENTMSG wMsg As Long lParamLow As Long lParamHigh As Long msgTime As Long hWndMsg As Long End TypeDim EMSG As EVENTMSGPublic Function SetHook() As Boolean If hJournalHook = 0 Then hJournalHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, App.hInstance, 0) If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID) SetHook = True End FunctionPublic Sub RemoveHook() UnhookWindowsHookEx hAppHook UnhookWindowsHookEx hJournalHook End SubPrivate Sub Class_Initialize() SHptr = ObjPtr(Me) End SubPrivate Sub Class_Terminate() If hJournalHook Or hAppHook Then RemoveHook End SubFriend Function FireEvent(ByVal lParam As Long) Dim i%, j%, k% Dim s As String If lParam = WM_CANCELJOURNAL Then hJournalHook = 0 SetHook Exit Function End If
CopyMemory EMSG, ByVal lParam, Len(EMSG) Select Case EMSG.wMsg Case WM_KEYDOWN j = 0 If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ s = Hex(EMSG.lParamLow) k = (EMSG.lParamLow And &HFF) RaiseEvent KeyDown(k, j) s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ EMSG.lParamLow = CLng("&h" & s) CopyMemory ByVal lParam, EMSG, Len(EMSG) Case WM_KEYUP j = 0 'fixed by JJ If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ s = Hex(EMSG.lParamLow) k = (EMSG.lParamLow And &HFF) RaiseEvent KeyUp(k, j) s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ EMSG.lParamLow = CLng("&h" & s) CopyMemory ByVal lParam, EMSG, Len(EMSG) Case WM_MOUSEMOVE i = 0 'fixed by JJ If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4) 'fixed by JJ j = 0 'fixed by JJ If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ RaiseEvent MouseMove(i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)) Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN i = 0 'fixed by JJ If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)) Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP i = 0 'fixed by JJ If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)) Case WM_SYSTEMKEYDOWN s = Hex(EMSG.lParamLow) k = (EMSG.lParamLow And &HFF) If k <> vbKeyMenu Then RaiseEvent SystemKeyDown(k) s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ EMSG.lParamLow = CLng("&h" & s) CopyMemory ByVal lParam, EMSG, Len(EMSG) Case WM_SYSTEMKEYUP s = Hex(EMSG.lParamLow) k = (EMSG.lParamLow And &HFF) If k <> vbKeyMenu Then RaiseEvent SystemKeyUp(k) s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ EMSG.lParamLow = CLng("&h" & s) CopyMemory ByVal lParam, EMSG, Len(EMSG) Case Else End Select End Function
mHook.basOption Explicit Type POINTAPI x As Long y As Long End TypeType TMSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End TypePublic Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long) Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public hJournalHook As Long, hAppHook As Long Public SHptr As Long Public Const WM_CANCELJOURNAL = &H4BPublic Function JournalRecordProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If nCode < 0 Then JournalRecordProc = CallNextHookEx(hJournalHook, nCode, wParam, lParam) Exit Function End If ResolvePointer(SHptr).FireEvent lParam Call CallNextHookEx(hJournalHook, nCode, wParam, lParam) End FunctionPublic Function AppHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If nCode < 0 Then AppHookProc = CallNextHookEx(hAppHook, nCode, wParam, lParam) Exit Function End If Dim msg As TMSG CopyMemory msg, ByVal lParam, Len(msg) Select Case msg.message Case WM_CANCELJOURNAL If wParam = 1 Then ResolvePointer(SHptr).FireEvent WM_CANCELJOURNAL End Select Call CallNextHookEx(hAppHook, nCode, wParam, ByVal lParam) End FunctionPrivate Function ResolvePointer(ByVal lpObj&) As cSystemHook Dim oSH As cSystemHook CopyMemory oSH, lpObj, 4& Set ResolvePointer = oSH CopyMemory oSH, 0&, 4& End Function
form1.frmOption ExplicitDim WithEvents sh As cSystemHook Private Declare Function GetForegroundWindow& Lib "user32" () Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long) Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long Private Const HWND_BOTTOM = 1 Private Const HWND_NOTOPMOST = -2 Private Const HWND_TOP = 0 Private Const HWND_TOPMOST = -1 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOSIZE = &H1 Private Declare Function GetActiveWindow Lib "user32" () As Long 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 LongPrivate Sub Form_Load() Set sh = New cSystemHook sh.SetHook End SubPrivate Sub Form_Unload(Cancel As Integer) sh.RemoveHook Set sh = Nothing End SubPrivate Sub sh_KeyDown(KeyCode As Integer, Shift As Integer) Dim s As String s = "KeyCode " & KeyCode s = s + CharFromKeyCode(KeyCode) If Shift = vbShiftMask Then s = s & " + Shift " If Shift = vbCtrlMask Then s = s & " + Ctrl " If Shift = vbAltMask Then s = s & " + Alt " Txt = Txt & vbCrLf & s & " down" End SubPrivate Function CharFromKeyCode(k As Integer) As String Dim s As String Select Case k Case vbKeyBack: s = "BackSpace" Case vbKeyTab: s = "Tab" Case vbKeyClear: s = "Clear" Case vbKeyReturn: s = "Enter" Case vbKeyShift: s = "Shift" Case vbKeyControl: s = "Ctrl" Case vbKeyMenu: s = "Alt" Case vbKeyPause: s = "Pause" Case vbKeyCapital: s = "CapsLock" Case vbKeyEscape: s = "ESC" Case vbKeySpace: s = "SPACEBAR" Case vbKeyPageUp: s = "PAGE UP" Case vbKeyPageDown: s = "PAGE DOWN" Case vbKeyEnd: s = "END" Case vbKeyHome: s = "HOME" Case vbKeyLeft: s = "LEFT ARROW" Case vbKeyUp: s = "UP ARROW" Case vbKeyRight: s = "RIGHT ARROW" Case vbKeyDown: s = "DOWN ARROW" Case vbKeySelect: s = "SELECT" Case vbKeyPrint: s = "PRINT SCREEN" Case vbKeyExecute: s = "EXECUTE" Case vbKeySnapshot: s = "SNAPSHOT" Case vbKeyInsert: s = "INS" Case vbKeyDelete: s = "DEL" Case vbKeyHelp: s = "HELP" Case vbKeyNumlock: s = "NUM LOCK" Case vbKey0 To vbKey9: s = Chr$(k) Case vbKeyA To vbKeyZ: s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))) Case vbKeyF1 To vbKeyF16: s = "F" & CStr(k - 111) Case vbKeyNumpad0 To vbKeyNumpad9: s = "Numpad " & CStr(k - 95) Case vbKeyMultiply: s = "Numpad {*}" Case vbKeyAdd: s = "Numpad {+}" Case vbKeySeparator: s = "Numpad {ENTER}" Case vbKeySubtract: s = "Numpad {-}" Case vbKeyDecimal: s = "Numpad {.}" Case vbKeyDivide: s = "Numpad {/}" Case Else s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))) End Select CharFromKeyCode = "[" & s & " key]" End Function
代码用了强制声明,但里面有个Txt没声明变量,导致出错应该加上 Dim Txt As String还有请问一下,虽然程序没错了但它如何记录键盘输入信息呢???记录后存在哪?
使用键盘HOOK或者输入法HOOK都可以
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event SystemKeyDown(KeyCode As Integer)
Public Event SystemKeyUp(KeyCode As Integer)Private Declare Function SetWindowsHookEx Lib "user32" 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" (ByVal hHook As Long) As Long
Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
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 Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_SYSTEMKEYDOWN = &H104
Private Const WM_SYSTEMKEYUP = &H105Private Const WH_JOURNALRECORD = 0
Private Const WH_GETMESSAGE = 3Private Type EVENTMSG
wMsg As Long
lParamLow As Long
lParamHigh As Long
msgTime As Long
hWndMsg As Long
End TypeDim EMSG As EVENTMSGPublic Function SetHook() As Boolean
If hJournalHook = 0 Then hJournalHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, App.hInstance, 0)
If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
SetHook = True
End FunctionPublic Sub RemoveHook()
UnhookWindowsHookEx hAppHook
UnhookWindowsHookEx hJournalHook
End SubPrivate Sub Class_Initialize()
SHptr = ObjPtr(Me)
End SubPrivate Sub Class_Terminate()
If hJournalHook Or hAppHook Then RemoveHook
End SubFriend Function FireEvent(ByVal lParam As Long)
Dim i%, j%, k%
Dim s As String
If lParam = WM_CANCELJOURNAL Then
hJournalHook = 0
SetHook
Exit Function
End If
CopyMemory EMSG, ByVal lParam, Len(EMSG)
Select Case EMSG.wMsg
Case WM_KEYDOWN
j = 0
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
RaiseEvent KeyDown(k, j)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_KEYUP
j = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
RaiseEvent KeyUp(k, j)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_MOUSEMOVE
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4) 'fixed by JJ
j = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
RaiseEvent MouseMove(i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ
RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ
RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_SYSTEMKEYDOWN
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
If k <> vbKeyMenu Then RaiseEvent SystemKeyDown(k)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_SYSTEMKEYUP
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
If k <> vbKeyMenu Then RaiseEvent SystemKeyUp(k)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case Else
End Select
End Function
Type POINTAPI
x As Long
y As Long
End TypeType TMSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End TypePublic Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public hJournalHook As Long, hAppHook As Long
Public SHptr As Long
Public Const WM_CANCELJOURNAL = &H4BPublic Function JournalRecordProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode < 0 Then
JournalRecordProc = CallNextHookEx(hJournalHook, nCode, wParam, lParam)
Exit Function
End If
ResolvePointer(SHptr).FireEvent lParam
Call CallNextHookEx(hJournalHook, nCode, wParam, lParam)
End FunctionPublic Function AppHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode < 0 Then
AppHookProc = CallNextHookEx(hAppHook, nCode, wParam, lParam)
Exit Function
End If
Dim msg As TMSG
CopyMemory msg, ByVal lParam, Len(msg)
Select Case msg.message
Case WM_CANCELJOURNAL
If wParam = 1 Then ResolvePointer(SHptr).FireEvent WM_CANCELJOURNAL
End Select
Call CallNextHookEx(hAppHook, nCode, wParam, ByVal lParam)
End FunctionPrivate Function ResolvePointer(ByVal lpObj&) As cSystemHook
Dim oSH As cSystemHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End Function
Private Declare Function GetForegroundWindow& Lib "user32" ()
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long)
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
Private Const HWND_BOTTOM = 1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Declare Function GetActiveWindow Lib "user32" () As Long
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 LongPrivate Sub Form_Load()
Set sh = New cSystemHook
sh.SetHook
End SubPrivate Sub Form_Unload(Cancel As Integer)
sh.RemoveHook
Set sh = Nothing
End SubPrivate Sub sh_KeyDown(KeyCode As Integer, Shift As Integer)
Dim s As String
s = "KeyCode " & KeyCode
s = s + CharFromKeyCode(KeyCode)
If Shift = vbShiftMask Then s = s & " + Shift "
If Shift = vbCtrlMask Then s = s & " + Ctrl "
If Shift = vbAltMask Then s = s & " + Alt "
Txt = Txt & vbCrLf & s & " down"
End SubPrivate Function CharFromKeyCode(k As Integer) As String
Dim s As String
Select Case k
Case vbKeyBack: s = "BackSpace"
Case vbKeyTab: s = "Tab"
Case vbKeyClear: s = "Clear"
Case vbKeyReturn: s = "Enter"
Case vbKeyShift: s = "Shift"
Case vbKeyControl: s = "Ctrl"
Case vbKeyMenu: s = "Alt"
Case vbKeyPause: s = "Pause"
Case vbKeyCapital: s = "CapsLock"
Case vbKeyEscape: s = "ESC"
Case vbKeySpace: s = "SPACEBAR"
Case vbKeyPageUp: s = "PAGE UP"
Case vbKeyPageDown: s = "PAGE DOWN"
Case vbKeyEnd: s = "END"
Case vbKeyHome: s = "HOME"
Case vbKeyLeft: s = "LEFT ARROW"
Case vbKeyUp: s = "UP ARROW"
Case vbKeyRight: s = "RIGHT ARROW"
Case vbKeyDown: s = "DOWN ARROW"
Case vbKeySelect: s = "SELECT"
Case vbKeyPrint: s = "PRINT SCREEN"
Case vbKeyExecute: s = "EXECUTE"
Case vbKeySnapshot: s = "SNAPSHOT"
Case vbKeyInsert: s = "INS"
Case vbKeyDelete: s = "DEL"
Case vbKeyHelp: s = "HELP"
Case vbKeyNumlock: s = "NUM LOCK"
Case vbKey0 To vbKey9: s = Chr$(k)
Case vbKeyA To vbKeyZ: s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
Case vbKeyF1 To vbKeyF16: s = "F" & CStr(k - 111)
Case vbKeyNumpad0 To vbKeyNumpad9: s = "Numpad " & CStr(k - 95)
Case vbKeyMultiply: s = "Numpad {*}"
Case vbKeyAdd: s = "Numpad {+}"
Case vbKeySeparator: s = "Numpad {ENTER}"
Case vbKeySubtract: s = "Numpad {-}"
Case vbKeyDecimal: s = "Numpad {.}"
Case vbKeyDivide: s = "Numpad {/}"
Case Else
s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
End Select
CharFromKeyCode = "[" & s & " key]"
End Function