Vb in achieving Mouse Gestures
Vb in achieving Mouse Gestures
1 What is a mouse gestures:
I understand it, according a mouse button (usually right) move the mouse, and then open up a button, the program will identify your mobile trajectory, the corresponding response.
2. Principle:
First of all note that I did not find in the Internet-related documents, I may not be the method is consistent with others, the actual results can be felt.
We track mouse movement can be seen as composed of many sub-line, and then these linear mouse in this direction is the direction of the trajectory of.
3. Codes:
To elaborate,
A) To capture the movement of the mouse, can be used in the mousemove vb incident, but this will be subject to certain restrictions (for example, in no webbrowser control on this incident). Therefore this example, I use the win api, in the proceedings installation of a mouse hook, and that the whole process can capture the mouse incident.
B), this is only a mouse can catch up, down, left and right movement example. (Oh, actually this is the general direction of the four enough:))
New Standrad EXE, add a Module
Form1 the code below
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 the code below
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 = "right"
Case 1
TStr = ""
Case 2
TStr = "left"
Case 3
TStr = ""
Case Else
TStr = "NONE"
End Select
Debug.Print Timer, tStr
DebugDir = tStr
End Function
Operating procedures, in the window, according Right move the mouse, Immediate Window shows the track of the mouse movement.
This constant ptGap inside is the "movement of the mouse trajectory we can be seen as composed of many sub-linear" in the square of the length of subparagraph. Used inside the api function usage, to refer to msdn. Here I lazy said.
Lingll (lingll2001@21cn.com)
2004-7-23
Notes not? Lazy ah, you will be on the all times:)
Tags: vb
0 Comments to “Vb in achieving Mouse Gestures”
No Comments. Send your comment.
Leave a Reply
You must be logged in to post a comment.