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