我的理解,按著鼠標某鍵(一般是右鍵)移動鼠標,然后放開某鍵,程序會識別你的移動軌跡,做出相應的響應.
2.實現原理:
首先說明一下,我在網上沒有找到相關的文檔,我的方法未必與其他人是一致的,實際效果感覺還可以.
鼠標移動的軌跡我們可以將其看成是許多小段直線組成的,然后這些直線的方向就是鼠標在這段軌跡中的方向了.
3.實現代碼:
還要說明一下,
a)要捕獲鼠標的移動事件,可以使用vb中的mousemove事件,但這個會受到一些限制(例如,在webbrowser控件上就沒有這個事件).于是這個例子中,我用win api,在程序中安裝個鼠標鉤子,這樣就能夠捕獲整個程序的鼠標事件了.
b)這個里只是個能捕獲鼠標向上,下,左,右的移動的例子.(呵呵,其實這四方向一般也足夠了:))
新建Standrad EXE,添加一個Module
form1的代碼如下
Option Explicit
Private Sub Form_Load()
Call InstallMouseHook
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call UninstallMouseHook
End Sub
Module1的代碼如下
Option Explicit
Public Const HTCLIENT As Long = 1
Private hMouseHook As Long
Private Const KF_UP As Long = &H80000000
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
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 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 Const WH_KEYBOARD As Long = 2
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 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 Const MK_RBUTTON As Long = &H2
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
Public Const VK_LBUTTON As Long = &H1
Public Const VK_RBUTTON As Long = &H2
Public Const VK_MBUTTON As Long = &H4
Dim mPt As POINTAPI
Const ptGap As Single = 5 * 5
Dim preDir As Long
Dim mouseEventDsp As String
Dim eventLength As Long
'######### mouse hook #############
Public Sub InstallMouseHook()
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
Cancel = False
On Error GoTo due
Dim i&
Dim nMouseInfo As MOUSEHOOKSTRUCT
Dim tHWindowFromPoint As Long
Dim tpt As POINTAPI
If iCode = HC_ACTION Then
CopyMemory nMouseInfo, ByVal lParam, Len(nMouseInfo)
tpt = nMouseInfo.pt
ScreenToClient nMouseInfo.hwnd, tpt
'Debug.Print tpt.X, tpt.Y
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
Exit Function
due:
End Function
Public Sub UninstallMouseHook()
If hMouseHook <> 0 Then
Call UnhookWindowsHookEx(hMouseHook)
End If
hMouseHook = 0
End Sub
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&, cy&
Dim rtn&
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 String
Dim tStr$
Select Case nDir
Case 0
tStr = "右"
Case 1
tStr = "上"
Case 2
tStr = "左"
Case 3
tStr = "下"
Case Else
tStr = "無"
End Select
Debug.Print Timer, tStr
DebugDir = tStr
End Function
運行程序后,在程序窗口上,按著右鍵移動鼠標,Immediate Window就會顯示出鼠標移動的軌跡了.
這里面的常數 ptGap 就是"鼠標移動的軌跡我們可以將其看成是許多小段直線組成的"中的小段的長度的平方.里面用到的api函數的用法,可以參考msdn.這里我就懶說了.
lingll (lingll2001@21cn.com)
2004-7-23
文章來源于領測軟件測試網 http://www.kjueaiud.com/
