vbAccelerator - Contents of code file: cMouseGestures.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cMouseGestures"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private 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
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)

Private Const WM_ACTIVATE As Long = &H6
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_RBUTTONUP As Long = &H205

Implements IWindowsHook

''' <summary>
''' Enumerated flag values for the mouse gestures supported by
''' the MouseGesture class.
''' </summary>
Public Enum MouseGestureTypes
    ''' <summary>
    ''' No mouse gesture.
    ''' </summary>
    NoGesture = &H0
    ''' <summary>
    ''' Mouse Gesture move north
    ''' </summary>
    NorthGesture = &H1
    ''' <summary>
    ''' Mouse Gesture move south
    ''' </summary>
    SouthGesture = &H2
    ''' <summary>
    ''' Mouse Gesture move east
    ''' </summary>
    EastGesture = &H4
    ''' <summary>
    ''' Mouse Gesture move west
    ''' </summary>
    WestGesture = &H8
    ''' <summary>
    ''' Mouse Gesture move north-east
    ''' </summary>
    NorthThenEastGesture = &H10
    ''' <summary>
    ''' Mouse Gesture move south-east
    ''' </summary>
    SouthThenEastGesture = &H20
    ''' <summary>
    ''' Mouse Gesture move south-west
    ''' </summary>
    SouthThenWestGesture = &H40
    ''' <summary>
    ''' Mouse Gesture move north-west
    ''' </summary>
    NorthThenWestGesture = &H80
    ''' <summary>
    ''' Mouse Gesture move north-east
    ''' </summary>
    EastThenNorthGesture = &H100
    ''' <summary>
    ''' Mouse Gesture move south-east
    ''' </summary>
    EastThenSouthGesture = &H200
    ''' <summary>
    ''' Mouse Gesture move south-west
    ''' </summary>
    WestThenSouthGesture = &H400
    ''' <summary>
    ''' Mouse Gesture move north-west
    ''' </summary>
    WestThenNorthGesture = &H800
    ''' <summary>
    ''' All mouse gestures
    ''' </summary>
    AllGestureTypes = &HFFF
End Enum

''' <summary>
''' The default absolute number of pixels the mouse must travel
''' in any direction for the gesture to be acknowledged.
''' </summary>
Private Const DEFAULT_HYSTERESIS_PIXELS As Integer = 8

''' <summary>
''' How far does the mouse have to move before it is
''' interpreted as a gesture?
''' </summary>
Private m_hysteresis As Long
''' <summary>
''' The configured mouse gesture types
''' </summary>
Private m_gestureTypes As MouseGestureTypes
''' <summary>
''' Whether we are checking for a gesture or not.
''' </summary>
Private m_checkingGesture As Boolean
''' <summary>
''' The recorded mouse gesture during gesture checking
''' </summary>
Private m_recordedGesture As MouseGestureTypes
''' <summary>
''' Array of mouse points recorded during gesture.
''' </summary>
Private m_gesture() As POINTAPI
Private m_gestureCount As Long

''' <summary>
''' Whether mouse gesture checking is attached or not
''' </summary>
Private m_bAttached As Boolean
''' <summary>
''' Whether right mouse button down on last hook event or not
''' </summary>
Private m_bRightDown As Boolean
Private m_iCancelRightUpHack As Long

Public Event MouseGesture( _
      ByVal gestureType As MouseGestureTypes, _
      ByVal xGestureStart As Long, ByVal yGestureStart As Long, _
      ByVal xGestureEnd As Long, ByVal yGestureEnd As Long, _
      ByRef acceptGesture As Boolean _
   )
   
Public Sub Attach()
   If Not (m_bAttached) Then
      InstallHook Me, WH_MOUSE
      m_bAttached = True
   End If
End Sub
Public Sub Detach()
   If (m_bAttached) Then
      RemoveHook Me, WH_MOUSE
      m_bAttached = False
   End If
End Sub

''' <summary>
''' Gets/sets the mouse gesture types to look for.
''' </summary>
Public Property Get GestureTypes() As MouseGestureTypes
   GestureTypes = m_gestureTypes
End Property
Public Property Let GestureTypes(ByVal Value As MouseGestureTypes)
   m_gestureTypes = Value
End Property

Private Sub Class_Initialize()
   m_gestureTypes = AllGestureTypes
End Sub

Private Sub Class_Terminate()
   Detach
End Sub

Private Function IWindowsHook_HookProc(ByVal eType As
 vbalWinHook6.EHTHookTypeConstants, ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long, bConsume As Boolean) As Long
   '
      
   Dim ret As Boolean
   
   Dim bRightDown As Boolean
   Dim iMsg As Long
   bRightDown = Not (GetAsyncKeyState(vbKeyRButton) = 0)
   If (bRightDown) Then
      If Not (m_bRightDown) Then
         m_bRightDown = True
         iMsg = WM_RBUTTONDOWN
      Else
         iMsg = WM_MOUSEMOVE
      End If
   ElseIf (m_bRightDown) Then
      m_bRightDown = False
      m_iCancelRightUpHack = 0       ' apologies
      iMsg = WM_RBUTTONUP
   Else
      ' eat next 10 mouse moves after right up
      If (m_iCancelRightUpHack < 10) Then
         m_iCancelRightUpHack = m_iCancelRightUpHack + 1
         ret = True
      End If
   End If
   
   If Not (ret) Then
      ret = PreFilterMessage(iMsg)
   End If
   
   If (ret) Then
      bConsume = True
      IWindowsHook_HookProc = 0
   End If
   
End Function

Private Function PreFilterMessage( _
      ByVal iMsg As Long _
   ) As Boolean
   Dim retValue As Boolean

   If (m_gestureTypes > 0) Then
      If (m_checkingGesture) Then
         If (iMsg = WM_MOUSEMOVE) Then
            Debug.Print "PreFilterMessage"
            AddToMouseGesture
         ElseIf (iMsg = WM_RBUTTONUP) Then
            Debug.Print "PreFilterMessage"
            retValue = EndMouseGesture()
            If (retValue) Then
               ' Windows will skip the next mouse down if we consume
               ' a mouse up.  m cannot be modified, despite being byref,
               ' so post a new one to a location which is offscreen:
               Dim offScreen As Long
               offScreen = &H7FFF7FFF
               PostMessage GetActiveWindow(), WM_RBUTTONUP, 0, offScreen
            End If
         ElseIf (iMsg = WM_ACTIVATE) Then
            m_checkingGesture = False
         End If

      ElseIf (iMsg = WM_RBUTTONDOWN) Then
         Debug.Print "PreFilterMessage"
         BeginMouseGesture
      End If
   End If

   PreFilterMessage = retValue
   
End Function
        
''' <summary>
'''
''' </summary>
Private Sub BeginMouseGesture()
   m_gestureCount = 1
   ReDim m_gesture(1 To m_gestureCount) As POINTAPI
   Dim tP As POINTAPI
   GetCursorPos tP
   LSet m_gesture(m_gestureCount) = tP
   m_checkingGesture = True
End Sub

''' <summary>
'''
''' </summary>
Private Sub AddToMouseGesture()
   m_gestureCount = m_gestureCount + 1
   ReDim Preserve m_gesture(1 To m_gestureCount) As POINTAPI
   Dim tP As POINTAPI
   GetCursorPos tP
   LSet m_gesture(m_gestureCount) = tP
End Sub

''' <summary>
'''
''' </summary>
''' <returns></returns>
Private Function EndMouseGesture() As Boolean

    m_checkingGesture = False

    Dim retValue As Boolean

    '' add the end point:
    AddToMouseGesture

    '' get start and end:
    Dim first As POINTAPI
    LSet first = m_gesture(1)
    Dim last As POINTAPI
    LSet last = m_gesture(m_gestureCount)

    '' check which directions we register a change in:
    Dim xDiff As Long
    xDiff = first.x - last.x
    Dim yDiff As Integer
    yDiff = first.y - last.y

    Dim north As Boolean
    Dim south As Boolean
    Dim east As Boolean
    Dim west As Boolean

    If (Abs(yDiff) > DEFAULT_HYSTERESIS_PIXELS) Then
        north = (yDiff > 0)
        south = Not (north)
    End If
    If (Abs(xDiff) > DEFAULT_HYSTERESIS_PIXELS) Then
        west = (xDiff > 0)
        east = Not (west)
    End If

    '' check for very narrow angles as these are probably not compound gestures
    If ((north Or south) And (east Or west)) Then
        If (Abs(xDiff) > Abs(yDiff)) Then
            If ((Abs(xDiff) / (Abs(yDiff) * 1#)) > 7) Then
               Debug.Print "Cancelling north/south contribution"
                north = False
                south = False
            End If
        Else
            If ((Abs(yDiff) / (Abs(xDiff) * 1#)) > 7) Then
               Debug.Print "Cancelling east/west contribution"
                east = False
                west = False
            End If
        End If
    End If

    m_recordedGesture = MouseGestureTypes.NoGesture

    If (north Or south) Then
        If (east Or west) Then
            ' compound gesture
            m_recordedGesture = interpretCompoundGesture(first, last, north,
             south, east, west)
        Else
            ' vertical gesture:
            If (north) Then
                m_recordedGesture = MouseGestureTypes.NorthGesture
            Else
                m_recordedGesture = MouseGestureTypes.SouthGesture
            End If
        End If
    ElseIf (east Or west) Then
        ' horizontal gesture
        If (east) Then
            m_recordedGesture = MouseGestureTypes.EastGesture
        Else
            m_recordedGesture = MouseGestureTypes.WestGesture
        End If
    End If

    If Not (m_recordedGesture = MouseGestureTypes.NoGesture) Then
        If Not ((GestureTypes And m_recordedGesture) = 0) Then
         Dim bAccept As Boolean
         RaiseEvent MouseGesture(m_recordedGesture, first.x, first.y, last.x,
          last.y, bAccept)
         retValue = bAccept
      End If
    End If

    EndMouseGesture = retValue
End Function

Private Function interpretCompoundGesture( _
    first As POINTAPI, last As POINTAPI, _
    ByVal north As Boolean, ByVal south As Boolean, ByVal east As Boolean,
     ByVal west As Boolean _
    ) As MouseGestureTypes

   Dim retValue As MouseGestureTypes
   retValue = MouseGestureTypes.NoGesture

   ' draw a diagonal line between start & end
   ' and determine if most points are y above
   ' the line or not:
   Dim pointAbove As Long
   pointAbove = 0
   Dim pointBelow As Long
   pointBelow = 0
    
   Dim i As Long
   Dim point As POINTAPI
   For i = 1 To m_gestureCount
      LSet point = m_gesture(i)
      Dim diagY As Long
      diagY = ((point.x - first.x) * (first.y - last.y)) / (first.x - last.x) +
       first.y
      If (point.y > diagY) Then
         pointAbove = pointAbove + 1
      Else
         pointBelow = pointBelow + 1
      End If
   Next i

    If (north) Then
        If (east) Then
            If (pointAbove > pointBelow) Then
                retValue = MouseGestureTypes.EastThenNorthGesture
            Else
                retValue = MouseGestureTypes.NorthThenEastGesture
            End If
        Else
            If (pointAbove > pointBelow) Then
                retValue = MouseGestureTypes.WestThenNorthGesture
            Else
                retValue = MouseGestureTypes.NorthThenWestGesture
            End If
        End If
    ElseIf (south) Then
        If (east) Then
            If (pointAbove > pointBelow) Then
                retValue = MouseGestureTypes.SouthThenEastGesture
            Else
                retValue = MouseGestureTypes.EastThenSouthGesture
            End If
        Else
            If (pointAbove > pointBelow) Then
                retValue = MouseGestureTypes.SouthThenWestGesture
            Else
                retValue = MouseGestureTypes.WestThenSouthGesture
            End If
        End If
    End If

   interpretCompoundGesture = retValue

End Function