keyboard/mouse hook

Option Explicit
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_COPYDATA As Long = &H4A
Private Const WM_USER As Long = &H400
Private Const WM_WHEEL As Long = (WM_USER + 1)
Private Const WM_KEYS As Long = (WM_USER + 2)
Private Const WM_REGHOOK As Long = (WM_USER + 3)
Private Const WM_UNREGHOOK As Long = WM_REGHOOK
Private Const WM_RESTART As Long = (WM_USER + 4)

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const WINDOW_NAME As String = "Audica_Dummy"
Private Const HOOK_NAME As String = "HookTool_Dummy"
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC As Long = -4
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hmenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private wnd As Long, dummy As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Public 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
Public Declare Function UnhookWindowsHookEx Lib "USER32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "USER32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HC_ACTION = 0
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_SYSKEYDOWN = &H104
Private Const WM_SYSKEYUP = &H105
Private Const WH_KEYBOARD_LL = 13
Private Const WM_MOUSEWHEEL = &H20A
Private Const WH_MOUSE_LL As Long = 14
Private Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    Flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private p As KBDLLHOOKSTRUCT
Private mou_rotat As Integer
Private kbd_hook_hndl As Long
Private mou_hook_hndl As Long
Public kbd_keys As New Collection 'Коллекция нажатых клавиш

Public Sub hook()
    kbd_hook_hndl = _
        SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf km_hook_proc, App.hInstance, 0)
    mou_hook_hndl = _
        SetWindowsHookEx(WH_MOUSE_LL, AddressOf km_hook_proc, App.hInstance, 0)
End Sub

Public Sub unhook()
    If kbd_hook_hndl <> 0 Then _
        UnhookWindowsHookEx kbd_hook_hndl
    kbd_hook_hndl = 0
    If mou_hook_hndl <> 0 Then _
        UnhookWindowsHookEx mou_hook_hndl
    mou_hook_hndl = 0
End Sub

Public Function km_hook_proc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If nCode = HC_ACTION Then
        Select Case wParam
        Case WM_MOUSEWHEEL
            CopyMemory mou_rotat, ByVal lParam + 10, 2
            PostMessage wnd, WM_WHEEL, App.hInstance, CLng(Sgn(mou_rotat))
        Case WM_KEYDOWN, WM_SYSKEYDOWN
            CopyMemory p, ByVal lParam, Len(p)
            If valByKey(p.vkCode) = -1 Then
                kbd_keys.Add p.vkCode, CStr(p.vkCode)
                If kbd_keys.Count = 1 Then _
                    PostMessage wnd, WM_KEYS, App.hInstance, 1
            End If
        Case WM_KEYUP, WM_SYSKEYUP
            CopyMemory p, ByVal lParam, Len(p)
            If valByKey(p.vkCode) <> -1 Then _
                kbd_keys.Remove CStr(p.vkCode)
            If kbd_keys.Count = 0 Then _
                PostMessage wnd, WM_KEYS, App.hInstance, -1
        End Select
    End If
    km_hook_proc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function

Private Function valByKey(ByVal key As String) As Long
On Error GoTo 1:
    valByKey = kbd_keys.Item(key)
Exit Function
1:  valByKey = -1
End Function

Private Function int_WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_UNREGHOOK Then Unload Form1
    int_WindowProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
End Function

'Найти сервер, создать дамми-окно, зарегистрировать его на сервере
Public Function findServer() As Boolean
    Dim prev As Long
    If b(prev, FindWindow(vbNullString, HOOK_NAME)) Then _
        PostMessage prev, WM_UNREGHOOK, 0, 0    'Выключить запущенный hooktool
    If b(wnd, FindWindow(vbNullString, WINDOW_NAME)) Then
        If dummy = 0 Then
            dummy = CreateWindowEx(0, "STATIC", HOOK_NAME, 0, 0, 0, 0, 0, 0, 0, 0, ByVal 0)
            SetWindowLong dummy, GWL_WNDPROC, AddressOf int_WindowProc
        End If
        PostMessage wnd, WM_REGHOOK, App.hInstance, dummy
        findServer = True
    End If
End Function

Public Sub destroyDummy()
    If dummy Then _
        DestroyWindow dummy
End Sub

Private Function b(p1 As Long, p2 As Long) As Boolean
    p1 = p2
    b = CBool(p1)
End Function