'鼠标钩子 Option Explicit Public Const WH_MOUSE As Long = 7 Public Const HC_SYSMODALOFF = 5 Public Const HC_SYSMODALON = 4 Public Const HC_SKIP = 2 Public Const HC_GETNEXT = 1 Public Const HC_ACTION = 0 Public Const HC_NOREMOVE As Long = 3 Public Const WM_LBUTTONDBLCLK As Long = &H203 Public Const WM_LBUTTONDOWN As Long = &H201 Public Const WM_LBUTTONUP As Long = &H202 Public Const WM_MBUTTONDBLCLK As Long = &H209 Public Const WM_MBUTTONDOWN As Long = &H207 Public Const WM_MBUTTONUP As Long = &H208 Public Const WM_RBUTTONDBLCLK As Long = &H206 Public Const WM_RBUTTONDOWN As Long = &H204 Public Const WM_RBUTTONUP As Long = &H205 Public Const WM_MOUSEMOVE As Long = &H200 Public Const WM_MOUSEWHEEL As Long = &H20A Public Const MK_RBUTTON As Long = &H2 Public Const VK_LBUTTON As Long = &H1 Public Const VK_RBUTTON As Long = &H2 Public Const VK_MBUTTON As Long = &H4 Private Type POINTAPI X As Long Y As Long End Type Public Type MOUSEHOOKSTRUCT pt As POINTAPI hwnd As Long wHitTestCode As Long dwExtraInfo As Long End Type Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Const ptGap As Single = 5 * 5 Private hMouseHook As Long Dim mPt As POINTAPI Dim preDir As Long, eventLength As Long, mouseEventDsp As String Public Sub InstallMouseHook() '安装 HOOK hMouseHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, App.ThreadID) End Sub Public Function MouseHookProc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim Cancel As Boolean, i As Long, tHWindowFromPoint As Long Dim nMouseInfo As MOUSEHOOKSTRUCT, tpt As POINTAPI On Error GoTo due Cancel = False If iCode = HC_ACTION Then CopyMemory nMouseInfo, ByVal lParam, Len(nMouseInfo) tpt = nMouseInfo.pt ScreenToClient nMouseInfo.hwnd, tpt If nMouseInfo.wHitTestCode = 1 Then Select Case wParam Case WM_RBUTTONDOWN mPt = nMouseInfo.pt preDir = -1 mouseEventDsp = "" Cancel = True Case WM_RBUTTONUP Debug.Print mouseEventDsp Cancel = True Case WM_MOUSEMOVE If vkPress(VK_RBUTTON) Then Call GetMouseEvent(nMouseInfo.pt) End If End Select End If End If If Cancel Then MouseHookProc = 1 Else MouseHookProc = CallNextHookEx(hMouseHook, iCode, wParam, lParam) End If due: End Function Public Function vkPress(vkcode As Long) As Boolean If (GetAsyncKeyState(vkcode) And &H8000) <> 0 Then vkPress = True Else vkPress = False End If End Function Public Function GetMouseEvent(nPt As POINTAPI) As Long Dim cx As Long, cy As Long, rtn As Long rtn = -1 cx = nPt.X - mPt.X: cy = -(nPt.Y - mPt.Y) If cx * cx + cy * cy > ptGap Then If cx > 0 And Abs(cy) <= cx Then rtn = 0 ElseIf cy > 0 And Abs(cx) <= cy Then rtn = 1 ElseIf cx < 0 And Abs(cy) <= Abs(cx) Then rtn = 2 ElseIf cy < 0 And Abs(cx) <= Abs(cy) Then rtn = 3 End If mPt = nPt If preDir <> rtn Then mouseEventDsp = mouseEventDsp & DebugDir(rtn) preDir = rtn End If End If GetMouseEvent = rtn End Function Public Function DebugDir(nDir As Long) As String Dim tStr As String Select Case nDir Case 0 tStr = "右" Case 1 tStr = "上" Case 2 tStr = "左" Case 3 tStr = "下" Case Else tStr = "无" End Select DebugDir = tStr End Function Public Sub UninstallMouseHook() '卸载 HOOK If hMouseHook <> 0 Then Call UnhookWindowsHookEx(hMouseHook) hMouseHook = 0 End Sub '键盘钩子 '窗口代码 Option Explicit Private Sub Form_Load() hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, 0&, App.ThreadID) End Sub Private Sub Form_Unload(Cancel As Integer) Call UnhookWindowsHookEx(hHook) End Sub '模块代码 Option Explicit 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 CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Const WH_KEYBOARD = 2 Public hHook As Long Public Function KeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If nCode >= 0 Then Form1.Print nCode & " " & wParam & " " & lParam End If KeyboardProc = CallNextHookEx(hHook, nCode, wParam, lParam) End Function