資訊好好玩

0愛的鼓勵 0訂閱站台

'以下在Form
Private Sub Form_Load()
Call EnableHook
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Debug.Print X; Y
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Debug.Print X; Y
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call FreeHook
End Sub

'以下在.Bas
 Public Const WH_MOUSE = 7
 Public Const WM_RBUTTONDOWN = &H204
 Public Const HC_ACTION = 0
 Public Const WM_RBUTTONUP = &H205

 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
 Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long
 Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
    ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
 Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
   (lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
 Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
 Public theForm As Form
 Public hHook As Long   ' handle of Hook Procedure
 Sub EnableHook()
    If hHook = 0 Then
       hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, 0)
    End If
 End Sub
 Sub FreeHook()
 Dim ret As Long
 If hHook <> 0 Then
    ret = UnhookWindowsHookEx(hHook)
    hHook = 0
 End If
 End Sub
 Function MouseHookProc(ByVal code As Long, ByVal wParam As Long, _
                 ByVal lParam As Long) As Long
  If code < 0 Then
     MouseHookProc = CallNextHookEx(hHook, code, wParam, lParam)
     Exit Function
  End If
  If wParam = WM_RBUTTONDOWN Or wParam = WM_RBUTTONUP Then
      MouseHookProc = 1 '表示不處理這個訊息
      Exit Function
  End If
  MouseHookProc = 0 '表示要處理這個訊息
  Call CallNextHookEx(hHook, code, wParam, lParam)
 End Function