VB编写全局HOOK

1. 一、新建一个ActiveX Dll工程，名字栏里取名为SysHook
   
2. 
   
3. 二、添加一个模块，取名为mHook，添加代码如下：
   
4. 
   
5. Option Explicit
   
6. Type POINTAPI
   
7.         x As Long
   
8.         y As Long
   
9. End Type
   
10. 
    
11. Type TMSG
    
12.     hwnd As Long
    
13.     message As Long
    
14.     wParam As Long
    
15.     lParam As Long
    
16.     time As Long
    
17.     pt As POINTAPI
    
18. End Type
    
19. 
    
20. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
    
21. Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
22. Public hJournalHook As Long, hAppHook As Long
    
23. Public SHptr As Long
    
24. Public Const WM_CANCELJOURNAL = &H4B
    
25. 
    
26. Public Function JournalRecordProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
27.   If nCode < 0 Then
    
28.      JournalRecordProc = CallNextHookEx(hJournalHook, nCode, wParam, lParam)
    
29.      Exit Function
    
30.   End If
    
31.   ResolvePointer(SHptr).FireEvent lParam
    
32.   Call CallNextHookEx(hJournalHook, nCode, wParam, lParam)
    
33. End Function
    
34. 
    
35. Public Function AppHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
36.    If nCode < 0 Then
    
37.       AppHookProc = CallNextHookEx(hAppHook, nCode, wParam, lParam)
    
38.       Exit Function
    
39.    End If
    
40.    Dim msg As TMSG
    
41.    CopyMemory msg, ByVal lParam, Len(msg)
    
42.    Select Case msg.message
    
43.        Case WM_CANCELJOURNAL
    
44.             If wParam = 1 Then ResolvePointer(SHptr).FireEvent WM_CANCELJOURNAL
    
45.    End Select
    
46.    Call CallNextHookEx(hAppHook, nCode, wParam, ByVal lParam)
    
47. End Function
    
48. 
    
49. Private Function ResolvePointer(ByVal lpObj&) As cSystemHook
    
50.   Dim oSH As cSystemHook
    
51.   CopyMemory oSH, lpObj, 4&
    
52.   Set ResolvePointer = oSH
    
53.   CopyMemory oSH, 0&, 4&
    
54. End Function
    
55. 
    
56. 三、把工程自动建立的Class1类模块改名为cSystemHook，添加代码如下：
    
57. 
    
58. Option Explicit
    
59. Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
60. Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    
61. Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
62. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
    
63. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
    
64. Public Event SystemKeyDown(KeyCode As Integer)
    
65. Public Event SystemKeyUp(KeyCode As Integer)
    
66. 
    
67. 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
    
68. Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    
69. Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
    
70. 
    
71. Private Const WM_KEYDOWN = &H100
    
72. Private Const WM_KEYUP = &H101
    
73. Private Const WM_MOUSEMOVE = &H200
    
74. Private Const WM_LBUTTONDOWN = &H201
    
75. Private Const WM_LBUTTONUP = &H202
    
76. Private Const WM_LBUTTONDBLCLK = &H203
    
77. Private Const WM_RBUTTONDOWN = &H204
    
78. Private Const WM_RBUTTONUP = &H205
    
79. Private Const WM_RBUTTONDBLCLK = &H206
    
80. Private Const WM_MBUTTONDOWN = &H207
    
81. Private Const WM_MBUTTONUP = &H208
    
82. Private Const WM_MBUTTONDBLCLK = &H209
    
83. Private Const WM_MOUSEWHEEL = &H20A
    
84. Private Const WM_SYSTEMKEYDOWN = &H104
    
85. Private Const WM_SYSTEMKEYUP = &H105
    
86. 
    
87. Private Const WH_JOURNALRECORD = 0
    
88. Private Const WH_GETMESSAGE = 3
    
89. 
    
90. Private Type EVENTMSG
    
91.      wMsg As Long
    
92.      lParamLow As Long
    
93.      lParamHigh As Long
    
94.      msgTime As Long
    
95.      hWndMsg As Long
    
96. End Type
    
97. 
    
98. Dim EMSG As EVENTMSG
    
99. 
    
100. Public Function SetHook() As Boolean
     
101.    If hJournalHook = 0 Then hJournalHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, App.hInstance, 0)
     
102.    If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
     
103.    SetHook = True
     
104. End Function
     
105. 
     
106. Public Sub RemoveHook()
     
107.    UnhookWindowsHookEx hAppHook
     
108.    UnhookWindowsHookEx hJournalHook
     
109.    hAppHook = 0
     
110.    hJournalHook = 0
     
111. End Sub
     
112. 
     
113. Private Sub Class_Initialize()
     
114.   SHptr = ObjPtr(Me)
     
115. End Sub
     
116. 
     
117. Private Sub Class_Terminate()
     
118.   If hJournalHook Or hAppHook Then RemoveHook
     
119. End Sub
     
120. 
     
121. Friend Function FireEvent(ByVal lParam As Long)
     
122.   Dim i%, j%, k%
     
123.   Dim s As String
     
124.   If lParam = WM_CANCELJOURNAL Then
     
125.      hJournalHook = 0
     
126.      SetHook
     
127.      Exit Function
     
128.   End If
     
129.   
     
130.   CopyMemory EMSG, ByVal lParam, Len(EMSG)
     
131.   Select Case EMSG.wMsg
     
132.     Case WM_KEYDOWN
     
133.          j = 0
     
134.          If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
     
135.          If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
     
136.          If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
     
137.          s = Hex(EMSG.lParamLow)
     
138.          k = (EMSG.lParamLow And &HFF)
     
139.          RaiseEvent KeyDown(k, j)
     
140.          s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
     
141.          EMSG.lParamLow = CLng("&h" & s)
     
142.          CopyMemory ByVal lParam, EMSG, Len(EMSG)
     
143.     Case WM_KEYUP
     
144.          j = 0                                                    'fixed by JJ
     
145.          If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
     
146.          If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
     
147.          If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
     
148.          s = Hex(EMSG.lParamLow)
     
149.          k = (EMSG.lParamLow And &HFF)
     
150.          RaiseEvent KeyUp(k, j)
     
151.          s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
     
152.          EMSG.lParamLow = CLng("&h" & s)
     
153.          CopyMemory ByVal lParam, EMSG, Len(EMSG)
     
154.     Case WM_MOUSEMOVE
     
155.          i = 0                                                    'fixed by JJ
     
156.          If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1)      'fixed by JJ
     
157.          If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2)      'fixed by JJ
     
158.          If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4)      'fixed by JJ
     
159.          j = 0                                                    'fixed by JJ
     
160.          If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
     
161.          If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
     
162.          If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
     
163.          RaiseEvent MouseMove(i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
     
164.     Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
     
165.          i = 0                                                    'fixed by JJ
     
166.          If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)        'fixed by JJ
     
167.          If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)      'fixed by JJ
     
168.          If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)         'fixed by JJ
     
169.          RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
     
170.     Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
     
171.          i = 0                                                    'fixed by JJ
     
172.          If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)        'fixed by JJ
     
173.          If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)      'fixed by JJ
     
174.          If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)         'fixed by JJ
     
175.          RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
     
176.     Case WM_SYSTEMKEYDOWN
     
177.          s = Hex(EMSG.lParamLow)
     
178.          k = (EMSG.lParamLow And &HFF)
     
179.          If k <> vbKeyMenu Then RaiseEvent SystemKeyDown(k)
     
180.          s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
     
181.          EMSG.lParamLow = CLng("&h" & s)
     
182.          CopyMemory ByVal lParam, EMSG, Len(EMSG)
     
183.     Case WM_SYSTEMKEYUP
     
184.          s = Hex(EMSG.lParamLow)
     
185.          k = (EMSG.lParamLow And &HFF)
     
186.          If k <> vbKeyMenu Then RaiseEvent SystemKeyUp(k)
     
187.          s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
     
188.          EMSG.lParamLow = CLng("&h" & s)
     
189.          CopyMemory ByVal lParam, EMSG, Len(EMSG)
     
190.     Case Else
     
191.   End Select
     
192. End Function
     
193. 
     
194. Public Property Get HookState() As Boolean
     
195.     If hAppHook = 0 Then
     
196.         HookState = False
     
197.     Else
     
198.         HookState = True
     
199.     End If
     
200. End Property
     
201. 
     
202. 
     
203. 
     
204. 四、千万别望了保存（否则你要后悔的），编译生成DLL，然后可以测试了，做一个普通的工程，添加引用SysHook，在窗体中添加测试代码（嘿嘿，可能你会吃点苦头）：
     
205. 
     
206. Option Explicit
     
207. 
     
208. Dim WithEvents sh As cSystemHook
     
209. 
     
210. Private Sub Form_Load()
     
211.    Set sh = CreateObject("syshook.cSystemHook")
     
212.    sh.SetHook
     
213. End Sub
     
214. 
     
215. Private Sub Form_Unload(Cancel As Integer)
     
216.   sh.RemoveHook
     
217.   Set sh = Nothing
     
218. End Sub
     
219. 
     
220. Private Sub sh_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
     
221.   If Button = 1 Then
     
222.     Text1 = "你按了左键，在坐标：X=" & x & " Y=" & y
     
223.   End If
     
224.   If Button = 2 Then
     
225.    Text1 = "你按了右键，在坐标：X=" & x & " Y=" & y
     
226.   End If
     
227. End Sub
     
228. 
     
229. 
     
230. 五、接着你可以试试全局的下列事件（记住刚才的教训，可要小心哦）：
     
231. 
     
232. Private Sub sh_KeyDown(KeyCode As Integer, Shift As Integer)
     
233. 
     
234. End Sub
     
235. 
     
236. Private Sub sh_KeyUp(KeyCode As Integer, Shift As Integer)
     
237. 
     
238. End Sub
     
239. 
     
240. MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
     
241. 
     
242. End Sub
     
243. 
     
244. Private Sub sh_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
     
245. 
     
246. End Sub
     
247. 
     
248. Private Sub sh_SystemKeyDown(KeyCode As Integer)
     
249. 
     
250. End Sub
     
251. 
     
252. Private Sub sh_SystemKeyUp(KeyCode As Integer)
     
253. 
     
254. End Sub
     

复制代码