VB实现的键盘HOOk钩子

时间:2021-05-02

看起来可能让你眼晕,但是只要你懂得VB知识,又想要这个东西的话,那你就得潜心研究一下了

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 LongPublic 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 StringPublic NUM As LongPublic OldHook As LongPublic LngClsPtr As LongPublic Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As LongIf nCode < 0 Then BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam) Exit FunctionEnd IfResolvePointer(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 LongEnd 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 LongPrivate Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As LongPrivate 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 LongDim Msg As EVENTMSGDim IntShift As IntegerDim IntCode As IntegerCopyMemory 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 SelectEnd FunctionPrivate Sub Class_Initialize()LngClsPtr = ObjPtr(Me)End Subform1.frmOption ExplicitDim WithEvents Hook As ClsHookPrivate Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As LongPrivate Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As LongPrivate Declare Function GetForegroundWindow Lib "user32" () As LongPrivate 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

本文源自:翔宇亭——IT乐园(http://),转载请保留此信息!

声明:本页内容来源网络,仅供用户参考;我单位不保证亦不表示资料全面及准确无误,也不保证亦不表示这些资料为最新信息,如因任何原因,本网内容或者用户因倚赖本网内容造成任何损失或损害,我单位将不会负任何法律责任。如涉及版权问题,请提交至online#300.cn邮箱联系删除。

相关文章