1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
| Option Explicit
' Модуль для перехвата событий ввода мыши и клавиатуры
' © Кривоус Анатолий Анатольевич (The trick), 2014
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 |