vbAccelerator - Contents of code file: cXButtonEvents.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cXButtonEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ---------------------------------------------------------------------
' vbAccelerator Software License
' Version 1.0
' Copyright (c) 2002 vbAccelerator.com
'
' Redistribution and use in source and binary forms, with or
' without modification, are permitted provided that the following
' conditions are met:
'
' 1. Redistributions of source code must retain the above copyright
'    notice, this list of conditions and the following disclaimer.
'
' 2. Redistributions in binary form must reproduce the above copyright
'    notice, this list of conditions and the following disclaimer in
'    the documentation and/or other materials provided with the distribution.
'
' 3. The end-user documentation included with the redistribution, if any,
'    must include the following acknowledgment:
'
'  "This product includes software developed by vbAccelerator
 (/index.html)."
'
' Alternately, this acknowledgment may appear in the software itself, if
' and wherever such third-party acknowledgments normally appear.
'
' 4. The name "vbAccelerator" must not be used to endorse or promote products
'    derived from this software without prior written permission. For written
'    permission, please contact vbAccelerator through steve@vbaccelerator.com.
'
' 5. Products derived from this software may not be called "vbAccelerator",
'    nor may "vbAccelerator" appear in their name, without prior written
'    permission of vbAccelerator.
'
' THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED WARRANTIES,
' INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
' AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
' VBACCELERATOR OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
' INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
' BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
' USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
' THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' ---------------------------------------------------------------------

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Const WM_XBUTTONDOWN = &H20B
Private Const WM_XBUTTONUP = &H20C
Private Const WM_XBUTTONDBLCLK = &H20D
Private Const WM_NCXBUTTONDOWN = &HAB
Private Const WM_NCXBUTTONUP = &HAC
Private Const WM_NCXBUTTONDBLCLK = &HAD

Private Const VK_XBUTTON1 = &H5&          '/* NOT contiguous with L & RBUTTON */
Private Const VK_XBUTTON2 = &H6&          '/* NOT contiguous with L & RBUTTON */

Private Const NC_XBUTTON1_MASK = &H10000
Private Const NC_XBUTTON2_MASK = &H20000

Private Const MK_LBUTTON = &H1
Private Const MK_RBUTTON = &H2
Private Const MK_SHIFT = &H4
Private Const MK_CONTROL = &H8
Private Const MK_MBUTTON = &H10
Private Const MK_XBUTTON1 = &H20
Private Const MK_XBUTTON2 = &H40

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long,
 ByVal yPoint As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

Implements ISubclass
Implements IWindowsHook

Public Enum XMouseButtonConstants
   XBUTTON1 = MK_XBUTTON1
   XBUTTON2 = MK_XBUTTON2
End Enum

Public Event XMouseDown(Button As XMouseButtonConstants, Shift As
 ShiftConstants, x As Single, y As Single, bConsumed As Boolean)
Public Event XMouseUp(Button As XMouseButtonConstants, Shift As ShiftConstants,
 x As Single, y As Single, bConsumed As Boolean)
Public Event XBtnDblClick(Button As XMouseButtonConstants, Shift As
 ShiftConstants, x As Single, y As Single, bConsumed As Boolean)

Private m_hWnd As Long
Private m_objTo As Object
Private m_bAnyChild As Boolean
Private m_eHookButtonDown As XMouseButtonConstants


Public Sub Attach( _
      objTo As Object, _
      Optional ByVal bAnyChild As Boolean = False _
   )
Dim hWndA As Long
   Detach
   Set m_objTo = objTo
   hWndA = m_objTo.hwnd
   m_bAnyChild = bAnyChild
   If (bAnyChild) Then
      m_bAnyChild = True
      InstallHook Me, WH_MOUSE
   Else
      m_bAnyChild = False
      AttachMessage Me, hWndA, WM_XBUTTONDOWN
      AttachMessage Me, hWndA, WM_XBUTTONUP
      AttachMessage Me, hWndA, WM_XBUTTONDBLCLK
      AttachMessage Me, hWndA, WM_NCXBUTTONDOWN
      AttachMessage Me, hWndA, WM_NCXBUTTONUP
      AttachMessage Me, hWndA, WM_NCXBUTTONDBLCLK
   End If
   m_hWnd = hWndA
End Sub
Public Sub Detach()
   If (m_hWnd) Then
      If (m_bAnyChild) Then
         RemoveHook Me, WH_MOUSE
      Else
         DetachMessage Me, m_hWnd, WM_XBUTTONDOWN
         DetachMessage Me, m_hWnd, WM_XBUTTONUP
         DetachMessage Me, m_hWnd, WM_XBUTTONDBLCLK
         DetachMessage Me, m_hWnd, WM_NCXBUTTONDOWN
         DetachMessage Me, m_hWnd, WM_NCXBUTTONUP
         DetachMessage Me, m_hWnd, WM_NCXBUTTONDBLCLK
      End If
      m_hWnd = 0
   End If
   Set m_objTo = Nothing
End Sub

Private Sub Class_Terminate()
   Detach
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
   '
   ISubclass_MsgResponse = emrPreprocess
   '
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
   '
   '
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
   '
Dim tP As POINTAPI
Dim x As Single
Dim y As Single
Dim eShift As ShiftConstants
Dim eBtn As XMouseButtonConstants
Dim bConsumed As Boolean
   
   Select Case iMsg
   Case WM_XBUTTONDOWN, WM_XBUTTONUP, WM_XBUTTONDBLCLK
      tP.x = (lParam And &HFFFF)
      tP.y = (lParam And &H7FFF0000) \ &H10000
      If (lParam And &H80000000) Then
         tP.y = tP.y Or &H8000&
      End If
      x = m_objTo.ScaleX(tP.x, vbTwips)
      y = m_objTo.ScaleX(tP.y, vbTwips)
      eBtn = (wParam And &H60&)
      eShift = (wParam And &HC&)
      If (iMsg = WM_XBUTTONDOWN) Then
         RaiseEvent XMouseDown(eBtn, eShift, x, y, bConsumed)
      ElseIf (iMsg = WM_XBUTTONUP) Then
         RaiseEvent XMouseUp(eBtn, eShift, x, y, bConsumed)
      Else
         RaiseEvent XBtnDblClick(eBtn, eShift, x, y, bConsumed)
      End If
      If (bConsumed) Then
         ISubclass_WindowProc = True
      End If
   
   Case WM_NCXBUTTONDOWN, WM_NCXBUTTONUP, WM_NCXBUTTONDBLCLK
      GetCursorPos tP
      ScreenToClient m_hWnd, tP
      x = m_objTo.ScaleX(tP.x, vbTwips)
      y = m_objTo.ScaleX(tP.y, vbTwips)
      If (lParam And &H10000) = &H10000 Then
         eBtn = XBUTTON1
      Else
         eBtn = XBUTTON2
      End If
      eShift = vbShiftMask * Abs(Not (GetAsyncKeyState(vbKeyShift) = 0)) Or _
            vbCtrlMask * Abs(Not (GetAsyncKeyState(vbKeyControl) = 0)) Or _
            vbAltMask * Abs(Not (GetAsyncKeyState(vbKeyMenu) = 0))
      If (iMsg = WM_XBUTTONDOWN) Then
         RaiseEvent XMouseDown(eBtn, eShift, x, y, bConsumed)
      ElseIf (iMsg = WM_XBUTTONUP) Then
         RaiseEvent XMouseUp(eBtn, eShift, x, y, bConsumed)
      Else
         RaiseEvent XBtnDblClick(eBtn, eShift, x, y, bConsumed)
      End If
      If (bConsumed) Then
         ISubclass_WindowProc = True
      End If
      
   End Select
   '
End Function

Private Function IWindowsHook_HookProc(ByVal eType As
 vbalWinHook.EHTHookTypeConstants, ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long, bConsume As Boolean) As Long
Dim tP As POINTAPI
Dim tR As RECT
Dim x As Single
Dim y As Single
Dim eShift As ShiftConstants
Dim hWndA As Long
Dim bOver As Boolean

   If ((wParam = WM_XBUTTONDOWN) Or _
      (wParam = WM_XBUTTONUP) Or _
      (wParam = WM_XBUTTONDBLCLK) Or _
      (wParam = WM_NCXBUTTONDOWN) Or _
      (wParam = WM_NCXBUTTONUP) Or _
      (wParam = WM_NCXBUTTONDBLCLK)) Then
   
      If Not (GetAsyncKeyState(VK_XBUTTON1) = 0) Then
         m_eHookButtonDown = XBUTTON1
      ElseIf Not (GetAsyncKeyState(VK_XBUTTON2) = 0) Then
         m_eHookButtonDown = XBUTTON2
      End If
         
      GetCursorPos tP
      hWndA = WindowFromPoint(tP.x, tP.y)
      Do While Not (bOver) And Not (hWndA = 0)
         If (hWndA = m_hWnd) Then
            bOver = True
         Else
            hWndA = GetParent(hWndA)
         End If
      Loop
         
      If bOver Then
         ScreenToClient m_hWnd, tP
         x = m_objTo.ScaleX(tP.x, vbTwips)
         y = m_objTo.ScaleX(tP.y, vbTwips)
         eShift = vbShiftMask * Abs(Not (GetAsyncKeyState(vbKeyShift) = 0)) Or _
               vbCtrlMask * Abs(Not (GetAsyncKeyState(vbKeyControl) = 0)) Or _
               vbAltMask * Abs(Not (GetAsyncKeyState(vbKeyMenu) = 0))
         
         bConsume = True ' If not true, the thing goes a bit mad!
         If (wParam = WM_XBUTTONDOWN) Or (wParam = WM_NCXBUTTONDOWN) Then
            RaiseEvent XMouseDown(m_eHookButtonDown, eShift, x, y, bConsume)
         ElseIf (wParam = WM_XBUTTONUP) Or (wParam = WM_NCXBUTTONUP) Then
            RaiseEvent XMouseUp(m_eHookButtonDown, eShift, x, y, bConsume)
         Else
            RaiseEvent XBtnDblClick(m_eHookButtonDown, eShift, x, y, bConsume)
         End If
      End If
      
   End If
   
End Function