Перехват нажатия клавиатуры в конкретном приложении

Option Explicit
 
Private Sub cmdRemoveHook_Click()
    UnHook
End Sub
Private Sub cmdSetHook_Click()
    Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
    UnHook
End Sub

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private Type KBDLLHOOKSTRUCT
    VkCode As Long
    ScanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
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 CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
 
Private Const WH_KEYBOARD_LL = 13
Private Const WH_MOUSE_LL = &HE&
Private Const HC_ACTION = 0
Private Const LLKHF_INJECTED = &H10
Private Const LLMHF_INJECTED = 1
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSEWHEEL As Long = &H20A
 
Dim hKeyHook As Long, hMouseHook As Long
 
Public Sub Hook()
    hKeyHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelkbdProc, App.hInstance, 0)
    If hKeyHook = 0 Then MsgBox ("Keyboard hook error")
    hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, App.hInstance, 0)
    If hMouseHook = 0 Then MsgBox ("Mouse hook error")
End Sub
Public Sub UnHook()
    If hKeyHook Then UnhookWindowsHookEx (hKeyHook): hKeyHook = 0
    If hMouseHook Then UnhookWindowsHookEx (hMouseHook): hMouseHook = 0
End Sub
' Процедура перехвата сообщений клавиатуры
Private Function LowLevelkbdProc(ByVal uCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
            frmMain.lstEvenst.AddItem KeyString(wParam) & _
                                      "KeyCode: " & lParam.VkCode & _
                                      " ScanCode: " & lParam.ScanCode & _
                                      IIf(lParam.flags And LLKHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        End Select
    End If
    LowLevelkbdProc = CallNextHookEx(hKeyHook, uCode, wParam, lParam)
End Function
' Процедура перехвата сообщений мыши
Private Function LowLevelMouseProc(ByVal uCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_MOUSEMOVE
            frmMain.lstEvenst.AddItem "MouseMove: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        Case WM_MOUSEWHEEL
            frmMain.lstEvenst.AddItem "MouseWheel: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      " Dir: " & IIf(lParam.mouseData > 0, "Forward", "Backward") & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        Case Else
            frmMain.lstEvenst.AddItem MouseString(wParam) & _
                                      " Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
            frmMain.lstEvenst.ListIndex = frmMain.lstEvenst.ListCount - 1
        End Select
    End If
    LowLevelMouseProc = CallNextHookEx(hMouseHook, uCode, wParam, lParam)
End Function
Private Function MouseString(WH As Long) As String
    Select Case WH
    Case WM_LBUTTONDOWN: MouseString = "MouseLButtonDown:"
    Case WM_LBUTTONUP: MouseString = "MouseLButtonUp:"
    Case WM_RBUTTONDOWN: MouseString = "MouseRButtonDown:"
    Case WM_RBUTTONUP: MouseString = "MouseRButtonUp:"
    Case WM_MBUTTONDOWN: MouseString = "MouseMButtonDown:"
    Case WM_MBUTTONUP: MouseString = "MouseMMuttonUp:"
    End Select
End Function
Private Function KeyString(WH As Long) As String
    Select Case WH
    Case WM_KEYDOWN: KeyString = "KeyDown:"
    Case WM_KEYUP: KeyString = "KeyUp:"
    Case WM_SYSKEYDOWN: KeyString = "KeySysDown:"
    Case WM_SYSKEYUP: KeyString = "KeySysUp:"
    End Select
End Function