Realization of mouse gesture in VB

Realization of mouse gesture in VB

1. What is a mouse gesture:
My understanding, press the mouse a key (generally right) to move the mouse, and then release a key, the program will identify your mobile trajectory, make corresponding response.

2. Principle of realization:
First of all, I did not find the relevant documents on the Internet, my method is not necessarily the same as other people, the actual effect of the feeling can be.
The trajectory of the mouse movement can be seen as a number of small lines, and then the direction of these lines is the direction of the mouse in this trajectory.
3. Implementation code:
Also to explain,
(a) To capture mouse movement events, you can use the MouseMove event in VB, but this is limited (for example, there is no such event on the WebBrowser control). So in this case, I use the win API to install a mouse hook in the program, This allows you to capture the entire program's mouse events.
b This is just an example of a move that captures the mouse up, down, left, and right. (Oh, in fact, these four directions are generally enough:))

New Standrad EXE, add a module

Form1 's code is as follows

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 's code is as follows

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 all, 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 Wpara M 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 = "Right"
Case 1
Tstr = "Up"
Case 2
Tstr = "Left"
Case 3
TSTR = "Down"
Case Else
Tstr = "None"
End Select
Debug.Print Timer, Tstr.
Debugdir = Tstr
End Function

After running the program, in the program window, press the right button to move the mouse, Immediate window will show the trajectory of the mouse movement.

The constant in this ptgap is "the trajectory of the mouse movement that we can see as the square of the length of a small segment of a number of small lines." The use of API functions inside can refer to MSDN. Here I am lazy to say.



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


No comments? Lazy, you will see it: