VB6实现键盘鼠标全局Hook

(声明：魏滔序原创，转贴请注明出处。)
标准模块(mHook)：

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length 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
Private Const WM_CANCELJOURNAL = &H4B

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type TMSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    Time As Long
    PT As POINTAPI
End Type

Public hJouHook As Long, hAppHook As Long, lpHooker As Long

Public Function JouHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If nCode < 0 Then
        JouHookProc = CallNextHookEx(hJouHook, nCode, wParam, lParam)
        Exit Function
    End If

    Call CallEvent(lpHooker, lParam)
    Call CallNextHookEx(hJouHook, nCode, wParam, lParam)
End Function

Public 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 Call CallEvent(lpHooker, WM_CANCELJOURNAL)
    End Select
    Call CallNextHookEx(hAppHook, nCode, wParam, ByVal lParam)
End Function

Private Sub CallEvent(ByVal lpObj As Long, ByVal lParam As Long)
    Dim Hooker As Hooker
    CopyMemory Hooker, lpObj, 4&
    Hooker.CallEvent lParam
    CopyMemory Hooker, 0&, 4&
End Sub

类模块(Hooker)：

Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
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 Const WH_JOURNALRECORD = &H0
Private Const WH_GETMESSAGE = &H3
Private Const WM_CANCELJOURNAL = &H4B

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 = &H105

Private Type EVENTMSG
    wMsg As Long
    lParamL As Long
    lParamH As Long
    msgTime As Long
    hWndMsg As Long
End Type

Private EMSG As EVENTMSG

Public 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 SysKeyDown(KeyCode As Integer)
Public Event SysKeyUp(KeyCode As Integer)

Public Sub CreateHook()
    If hJouHook = 0 Then hJouHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JouHookProc, App.hInstance, 0)
    If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
End Sub

Public Property Get HookState() As Boolean
    If hAppHook = 0 Then
        HookState = False
    Else
        HookState = True
    End If
End Property

Public Sub RemoveHook()
    UnhookWindowsHookEx hAppHook: hAppHook = 0
    UnhookWindowsHookEx hJouHook: hJouHook = 0
End Sub

Private Sub Class_Initialize()
    lpHooker = ObjPtr(Me)
End Sub

Private Sub Class_Terminate()
    If hJouHook Or hAppHook Then RemoveHook
End Sub

Friend Sub CallEvent(ByVal lParam As Long)
    Dim i As Integer, j As Integer, K As Integer, s As String

    If lParam = WM_CANCELJOURNAL Then
        hJouHook = 0: CreateHook
        Exit Sub
    End If

    CopyMemory EMSG, ByVal lParam, Len(EMSG)

    Select Case EMSG.wMsg
        Case WM_KEYDOWN
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)

            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            RaiseEvent KeyDown(K, j)

            s = Left$(s, 2) & Right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_KEYUP
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            RaiseEvent KeyUp(K, j)

            s = Left$(s, 2) & Right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_MOUSEMOVE
            If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4)
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)

            RaiseEvent MouseMove(i, j, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
            If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)

            RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
            If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)

            RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_SYSTEMKEYDOWN
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            If K <> vbKeyMenu Then RaiseEvent SysKeyDown(K)

            s = Left$(s, 2) & Right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_SYSTEMKEYUP
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            If K <> vbKeyMenu Then RaiseEvent SysKeyUp(K)

            s = Left$(s, 2) & Right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case Else
    End Select
End Sub

应网友要求，在此补充示例代码：

Option Explicit
Private WithEvents Hooker As Hooker

Private Sub Form_Load()
    Set Hooker = New Hooker
    Hooker.CreateHook
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Hooker.RemoveHook
    Set Hooker = Nothing
End Sub

Private Sub Hooker_KeyUp(KeyCode As Integer, Shift As Integer)
    Debug.Print KeyCode, Shift
End Sub

Private Sub Hooker_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Debug.Print Button, Shift, x, y
End Sub

Private Sub Hooker_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Debug.Print Button, Shift, x, y
End Sub

Private Sub Hooker_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Debug.Print Button, Shift, x, y
End Sub

Private Sub Hooker_SysKeyDown(KeyCode As Integer)
    Debug.Print KeyCode
End Sub

Private Sub Hooker_SysKeyUp(KeyCode As Integer)
    Debug.Print KeyCode
End Sub