还是老掉牙的问题：窗口hook问题

在http://www.codeproject.com搜“Hook”

解决方案 »

  1.   

    原来若干年前就已经收藏过（不知原作者是谁，抱歉啦同时感谢他），只是一直未曾使用过。这个代码是全局鼠标键盘监控的，而且可以多个实例同时运行。但有一点小小遗憾：
    1、不知道怎么获取Mouse_Wheel事件中的WheelData值？
    2、不知怎么吃掉消息。Form1窗体：请添加一个自动换行的Text1
    Option Explicit
    Private WithEvents Hooker As Hooker
    Private Sub Form_Click()
        Text1.Text = ""
    End Sub
    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)
        Text1.Text = Text1.Text & vbCrLf & "Hooker_KeyUp---" & KeyCode & "," & Shift
    End Sub
    Private Sub Hooker_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Text1.Text = Text1.Text & vbCrLf & "Hooker_MouseDown--" & Button & "," & Shift & "," & X & "," & Y
    End Sub
    Private Sub Hooker_MouseWheel(WheelDeta As Long)
        Text1.Text = Text1.Text & vbCrLf & "Hooker_MouseWheel--" & WheelDeta
    End SubModule1代码：
    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
    Public 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&
        Call 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 LongPrivate Const WH_JOURNALRECORD = &H0
    Private Const WH_GETMESSAGE = &H3
    Private Const WM_CANCELJOURNAL = &H4BPrivate 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 MouseWheel(WheelDeta As Long) ''怎么弄这个？
    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, lRet As Long
        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_MOUSEWHEEL
                RaiseEvent MouseWheel(EMSG.lParamL) ''这个WheelData怎么获取？
            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
    大侠们给看看，怎么在原代码的基础上完善一下，添加以下2项功能，可以方便大家使用！！
    1、找出WheelData，完善Mouse_Wheel事件；
    2、在事件代码中添加一个开关，在有必要的时候吃掉某个消息。比如在窗体中：Private Sub Hooker_MouseWheel(WheelDeta As Long,iRet as Long)
        Text1.Text = Text1.Text & vbCrLf & "Hooker_MouseWheel--" & WheelDeta
        iRet=-1 ''当iRet=-1或其它值时会吃掉这个消息
    End Sub