在vb中实现鼠标手势
1.什么是鼠标手势:
???我的理解,按着鼠标某键(一般是右键)移动鼠标,然后放开某键,程序会识别你的移动轨迹,做出相应的响应.
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) ??????? rtn = 0
??? ElseIf cy > 0 And Abs(cx) ??????? rtn = 1
??? ElseIf cx ??????? rtn = 2
??? ElseIf cy ??????? 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
没有注释?懒啊,各位就将就着看吧:)