在vb中实现鼠标手势

1.什么是鼠标手势:   我的理解,按着鼠标某键(一般是右键)移动鼠标,然后放开某键,程序会识别你的移动轨迹,做出相应的响应.2.实现原理: 首先说明一下,我在网上没有找到相关的文档,我的方法未必与其他人是一致的,实际效果感觉还可以. 鼠标移动的轨迹我们可以将其看成是许多小段直线组成的,然后这些直线的方向就是鼠标在这段轨迹中的方向了.3.实现代码: 还要说明一下, a)要捕获鼠标的移动事件,可以使用vb中的mousemove事件,但这个会受到一些限制(例如,在webbrowser控件上就没有这个事件).于是这个例子中,我用win api,在程序中安装个鼠标钩子,这样就能够捕获整个程序的鼠标事件了. b)这个里只是个能捕获鼠标向上,下,左,右的移动的例子.(呵呵,其实这四方向一般也足够了:))

新建Standrad EXE,添加一个Module

form1的代码如下

Option Explicit

Private Sub Form_Load()Call InstallMouseHookEnd Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)Call UninstallMouseHookEnd Sub

Module1的代码如下

Option Explicit

Public Const HTCLIENT As Long = 1

Private hMouseHook As LongPrivate 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 LongPublic Declare Function SetWindowsHookEx Lib "user32" _        Alias "SetWindowsHookExA" _        (ByVal idHook As Long, _        ByVal lpfn As Long, _        ByVal hmod As Long, _        ByVal dwThreadId As Long) As LongPublic Declare Function UnhookWindowsHookEx Lib "user32" _        (ByVal hHook As Long) As Long

Public Const WH_KEYBOARD As Long = 2Public Const WH_MOUSE As Long = 7

Public Const HC_SYSMODALOFF = 5Public Const HC_SYSMODALON = 4Public Const HC_SKIP = 2Public Const HC_GETNEXT = 1Public Const HC_ACTION = 0Public Const HC_NOREMOVE As Long = 3

Public Const WM_LBUTTONDBLCLK As Long = &H203Public Const WM_LBUTTONDOWN As Long = &H201Public Const WM_LBUTTONUP As Long = &H202Public Const WM_MBUTTONDBLCLK As Long = &H209Public Const WM_MBUTTONDOWN As Long = &H207Public Const WM_MBUTTONUP As Long = &H208Public Const WM_RBUTTONDBLCLK As Long = &H206Public Const WM_RBUTTONDOWN As Long = &H204Public Const WM_RBUTTONUP As Long = &H205Public Const WM_MOUSEMOVE As Long = &H200Public 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 LongPublic Const MK_RBUTTON As Long = &H2Public 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 IntegerPublic Const VK_LBUTTON As Long = &H1Public Const VK_RBUTTON As Long = &H2Public Const VK_MBUTTON As Long = &H4

Dim mPt As POINTAPIConst ptGap As Single = 5 * 5Dim preDir As LongDim mouseEventDsp As StringDim 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 LongDim Cancel As BooleanCancel = FalseOn Error GoTo dueDim i&Dim nMouseInfo As MOUSEHOOKSTRUCTDim tHWindowFromPoint As LongDim 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 = 1Else    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 = 0End Sub

Public Function vkPress(vkcode As Long) As BooleanIf (GetAsyncKeyState(vkcode) And &H8000) <> 0 Then    vkPress = TrueElse    vkPress = FalseEnd IfEnd Function

Public Function GetMouseEvent(nPt As POINTAPI) As LongDim cx&, cy&Dim rtn&rtn = -1cx = 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 IfEnd IfGetMouseEvent = rtnEnd Function

Public Function DebugDir(nDir&) As StringDim tStr$Select Case nDir    Case 0        tStr = "右"    Case 1        tStr = "上"    Case 2        tStr = "左"    Case 3        tStr = "下"    Case Else        tStr = "无"End SelectDebug.Print Timer, tStrDebugDir = tStrEnd Function

运行程序后,在程序窗口上,按着右键移动鼠标,Immediate Window就会显示出鼠标移动的轨迹了.

这里面的常数 ptGap 就是"鼠标移动的轨迹我们可以将其看成是许多小段直线组成的"中的小段的长度的平方.里面用到的api函数的用法,可以参考msdn.这里我就懒说了.

 

lingll (lingll2001@21cn.com)2004-7-23