请问怎样在VB中截取外部应用程序（有焦点）中鼠标事件，如禁止EXCEL中点击右键？

Question

我希望在EXCEL获得焦点时，可以在VB代码或VBA代码中禁止用户点击右键，目的是禁止用户自定义工具栏和菜单栏，怎么实现呢？请教高手！

Answer 1

'系统必须为Win2000或以上版本
'不过所有的Excel右键都屏蔽了,你可以再加工一下
'判断当前鼠标的下的窗体句柄，不是菜单编辑项，则不屏蔽
'模块
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
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Public Type KEYMSGS
       vKey As Long          '虚拟码  (and &HFF)
       sKey As Long          '扫描码
       flag As Long          '键按下：128 抬起：0
       time As Long          'Window运行时间
End Type
Public Type MOUSEMSGS
       X As Long            'x座标
       Y As Long            'y座标
       a As Long
       b As Long
       time As Long         'Window运行时间
End Type
Public Type POINTAPI
    X As Long
    Y As Long
End Type
Public Const WH_KEYBOARD_LL = 13
Public Const WH_MOUSE_LL = 14
Public Const Alt_Down = &H20
'-----------------------------------------
'消息
Public Const HC_ACTION = 0
Public Const HC_SYSMODALOFF = 5
Public Const HC_SYSMODALON = 4
'鼠标消息
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_MOUSEACTIVATE = &H21
Public Const WM_MOUSEFIRST = &H200
Public Const WM_MOUSELAST = &H209
Public Const WM_MOUSEWHEEL = &H20A
Public Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public strKeyName As String * 255
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public keyMsg As KEYMSGS
Public MouseMsg As MOUSEMSGS
Public lHook(1) As Long
'----------------------------------------
'模拟鼠标
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 '  absolute move
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetFocus Lib "user32" () As Long'---------------------------------
'安装钩子
Public Sub AddHook()
  '鼠标钩子
  lHook(0) = SetWindowsHookEx(WH_MOUSE_LL, AddressOf CallMouseHookProc, App.hInstance, 0)
End Sub
'卸钩子
Public Sub DelHook()
  UnhookWindowsHookEx lHook(0)
End Sub
'---------------------------------
'鼠标钩子
Public Function CallMouseHookProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim pt As POINTAPI    If code = HC_ACTION Then
      CopyMemory MouseMsg, lParam, LenB(MouseMsg)
      
      If wParam = WM_RBUTTONDOWN Then                          '我的Excel的类名为XLMAIN，你要确认你的
         If FindWindow(XLMAIN, vbNullString) = GetFocus() Then '如果是Excel，则屏蔽右键
           CallMouseHookProc = 1
         End If
      End If
        
    End If
    
    If code <> 0 Then
      CallMouseHookProc = CallNextHookEx(0, code, wParam, lParam)
    End If
  
End Function
'Form
Option ExplicitPrivate Sub Form_Load()
 AddHook
End SubPrivate Sub Form_Unload(Cancel As Integer)
 DelHook
End Sub

Answer 2

yefanqiu,非常感谢,果然是高手.还想请教是不是SetWindowsHookEx只在WIN2000下才有?
另外有一段代码看不懂:
  If code = HC_ACTION Then
      CopyMemory MouseMsg, lParam, LenB(MouseMsg)
和
If code <> 0 Then
      CallMouseHookProc = CallNextHookEx(0, code, wParam, lParam)
    End If
啥意思?能否解释一下,谢谢!

Answer 3

SetWindowsHookEx 98下也有，不过以下两个参数不能用，仅NT下使用，它能不用DLL就能实现全局钩子，在98下也可以用参数为0，实现全局钩子，不过这样的钩子系统中只能有一个，否则出问题。
Public Const WH_KEYBOARD_LL = 13
Public Const WH_MOUSE_LL = 14  CopyMemory MouseMsg, lParam, LenB(MouseMsg)
   lParam 是存放信息的地址指针，在那里取鼠标或键盘信息  '把信息传递给钩子链中的下一个钩子函数
  CallMouseHookProc = CallNextHookEx(0, code, wParam, lParam)