vbAccelerator - Contents of code file: Mouse_frmMouseHook.frm

VERSION 5.00
Begin VB.Form frmMouseHook 
   Caption         =   "vbAccelerator Windows Hooks - Mouse"
   ClientHeight    =   6495
   ClientLeft      =   3090
   ClientTop       =   2355
   ClientWidth     =   5400
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmMouseHook.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6495
   ScaleWidth      =   5400
   Begin VB.Frame fraTest 
      Caption         =   "Test Frame"
      Height          =   735
      Left            =   60
      TabIndex        =   18
      Top             =   3480
      Width           =   5175
      Begin VB.TextBox txtTest4 
         Height          =   285
         Left            =   120
         TabIndex        =   20
         Text            =   "Text1"
         Top             =   300
         Width           =   2595
      End
      Begin VB.Label lblInfo 
         Caption         =   "Label Within a Frame"
         Height          =   195
         Index           =   3
         Left            =   3000
         TabIndex        =   19
         Top             =   180
         Width           =   1935
      End
   End
   Begin VB.CheckBox chkSelect 
      Caption         =   """&Select"" Controls"
      Height          =   255
      Left            =   60
      TabIndex        =   17
      Top             =   840
      Width           =   1575
   End
   Begin VB.PictureBox picContainer 
      Height          =   1395
      Left            =   2940
      ScaleHeight     =   1335
      ScaleWidth      =   2235
      TabIndex        =   12
      Top             =   2040
      Width           =   2295
      Begin VB.OptionButton optTest 
         Caption         =   "Option1"
         Height          =   195
         Index           =   1
         Left            =   60
         TabIndex        =   16
         Top             =   1080
         Width           =   2055
      End
      Begin VB.OptionButton optTest 
         Caption         =   "Option1"
         Height          =   195
         Index           =   0
         Left            =   60
         TabIndex        =   15
         Top             =   840
         Value           =   -1  'True
         Width           =   2055
      End
      Begin VB.CommandButton cmdTestChild2 
         Caption         =   "Command1"
         Height          =   315
         Left            =   60
         Style           =   1  'Graphical
         TabIndex        =   14
         Top             =   420
         Width           =   1275
      End
      Begin VB.CommandButton cmdTestChild1 
         Caption         =   "Command1"
         Height          =   315
         Left            =   60
         Style           =   1  'Graphical
         TabIndex        =   13
         Top             =   60
         Width           =   1275
      End
   End
   Begin VB.TextBox txtTest 
      Height          =   855
      Left            =   60
      TabIndex        =   6
      Text            =   "Text1"
      Top             =   1620
      Width           =   2715
   End
   Begin VB.TextBox txtUnaffected 
      Height          =   315
      Left            =   60
      TabIndex        =   5
      Text            =   "Text1"
      Top             =   4620
      Width           =   2775
   End
   Begin VB.ListBox lstUnaffected 
      Height          =   840
      Left            =   60
      TabIndex        =   4
      Top             =   5040
      Width           =   2775
   End
   Begin VB.CommandButton cmdTest1 
      Caption         =   "Command1"
      Height          =   315
      Left            =   2940
      Style           =   1  'Graphical
      TabIndex        =   3
      Top             =   4620
      Width           =   1275
   End
   Begin VB.CommandButton cmdTest2 
      Caption         =   "Command1"
      Height          =   315
      Left            =   2940
      Style           =   1  'Graphical
      TabIndex        =   2
      Top             =   4980
      Width           =   1275
   End
   Begin VB.ComboBox cboTest 
      Height          =   315
      Left            =   2940
      TabIndex        =   1
      Text            =   "Combo1"
      Top             =   1620
      Width           =   2295
   End
   Begin VB.ListBox lstTest 
      Height          =   840
      Left            =   60
      TabIndex        =   0
      Top             =   2580
      Width           =   2715
   End
   Begin VB.Label lblMousePos 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Label1"
      Height          =   315
      Left            =   4020
      TabIndex        =   11
      Top             =   6120
      Width           =   1335
   End
   Begin VB.Label lblStatus 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Label1"
      Height          =   315
      Left            =   60
      TabIndex        =   10
      Top             =   6120
      Width           =   3855
   End
   Begin VB.Label lblInfo 
      Caption         =   "This is an information label"
      Height          =   195
      Index           =   0
      Left            =   60
      TabIndex        =   9
      Top             =   1320
      Width           =   5175
   End
   Begin VB.Label lblInfo 
      Caption         =   $"frmMouseHook.frx":1272
      Height          =   615
      Index           =   1
      Left            =   60
      TabIndex        =   8
      Top             =   60
      Width           =   5235
   End
   Begin VB.Label lblInfo 
      Caption         =   "This is an information label"
      Height          =   315
      Index           =   2
      Left            =   60
      TabIndex        =   7
      Top             =   4320
      Width           =   5175
   End
End
Attribute VB_Name = "frmMouseHook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Implements IWindowsHook

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
 Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long,
 ByVal yPoint As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private m_objParent As Object
Private m_iSelCount As Long

Private Function FindControl(ByVal lhWndCmp, ByVal x As Long, ByVal y As Long,
 ByRef ctlOver As Control)
Dim lhWNd As Long
   ' This returns the window the mouse is over:
   lhWNd = WindowFromPoint(x, y)
   ' Now if we get a window, we need to find what control
   ' it is.  Some controls don't have a window handle.  The
   ' handle for these controls is the parent handle.  Some
   ' controls (e.g. combo box) have sub windows.
   If lhWNd <> 0 Then
      ' Check if a direct control hWnd:
      If Not IsControl(lhWNd, ctlOver) Then
         ' Check if a child of any control
         If Not IsChildOfControl(lhWNd, ctlOver) Then
            ' Check for control without hWnd:
            IsControlNohWnd lhWNd, ctlOver, x, y
         End If
      Else
         ' Check if we have a control without hWnd
         ' contained within this hWnd which is actually what the
         ' mouse is over:
         IsControlNohWnd lhWNd, ctlOver, x, y
      End If
   End If
   
End Function
Private Function IsControlNohWnd(ByVal lhWndParent As Long, ctlOver As Control,
 ByVal x As Long, ByVal y As Long) As Boolean
Dim ctl As Control
Dim lhWndC As Long
Dim objParent As Object
Dim tP As POINTAPI
   If lhWndParent = Me.hwnd Then
      Set objParent = Me
   Else
      For Each ctl In Me.Controls
         On Error Resume Next
         lhWndC = ctl.hwnd
         If Err.Number <> 0 Then lhWndC = 0
         If lhWndC = lhWndParent Then
            Set objParent = ctl
            Exit For
         End If
      Next
   End If
   If Not objParent Is Nothing Then
      For Each ctl In Me.Controls
         On Error Resume Next
         If ctl.Container Is objParent Then
            tP.x = x: tP.y = y
            ScreenToClient objParent.hwnd, tP
            If tP.x >= ctl.Left \ Screen.TwipsPerPixelX And tP.x <= (ctl.Left +
             ctl.Width) \ Screen.TwipsPerPixelX Then
               If tP.y >= ctl.Top \ Screen.TwipsPerPixelX And tP.y <= (ctl.Top
                + ctl.Height) \ Screen.TwipsPerPixelX Then
                  Set ctlOver = ctl
                  IsControlNohWnd = True
               End If
            End If
         End If
      Next
   End If
End Function

Private Function IsControl(ByVal lhWNd As Long, ByRef ctlOver As Control)
Dim ctl As Control
Dim lhWndC As Long
   For Each ctl In Me.Controls
      On Error Resume Next
      lhWndC = ctl.hwnd
      If Err.Number <> 0 Then lhWndC = 0
      If lhWNd = lhWndC Then
         IsControl = True
         Set ctlOver = ctl
         Exit For
      End If
   Next
End Function
Private Function IsChildOfControl(ByVal lhWNd As Long, ByRef ctlOver As Control)
Dim ctl As Control
Dim lhWndC As Long
   For Each ctl In Me.Controls
      On Error Resume Next
      lhWndC = ctl.hwnd
      If Err.Number <> 0 Then lhWndC = 0
      If lhWndC <> 0 Then
         If IsChildWindow(lhWndC, lhWNd) Then
            Set ctlOver = ctl
            Exit For
         End If
      End If
   Next
End Function

Private Sub Form_Load()
   installhook Me, WH_MOUSE
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   removehook Me, WH_MOUSE
End Sub

Private Function IWindowsHook_HookProc(ByVal eType As EHTHookTypeConstants,
 ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long, bConsume As
 Boolean) As Long
Dim ctlOver As Control
Dim bS As Boolean
Dim lC As Long
Dim lhWNd As Long
Dim bSkip As Boolean
Static ctlIgnore As Control

   With MouselParam(lParam)
      Select Case wParam
      Case WM_MOUSEMOVE
   
         lblMousePos.Caption = .x & "," & .y
         
         FindControl .hwnd, .x, .y, ctlOver
         If Not ctlOver Is Nothing Then
            lblStatus.Caption = ctlOver.Name
         Else
            lblStatus.Caption = ""
         End If
      
      Case WM_NCMOUSEMOVE
         lblStatus.Caption = "Mouse in Non-Client area"
      
      Case WM_LBUTTONUP, WM_LBUTTONDOWN
         If .hwnd <> chkSelect.hwnd Then
            If chkSelect.Value = Checked Then
               Debug.Print wParam
               FindControl .hwnd, .x, .y, ctlOver
               If Not ctlOver Is Nothing Then
                  bConsume = True
                  ' Check for control having the same
                  ' parent as other selections:
                  If m_objParent Is Nothing Then
                     Set m_objParent = ctlOver.Container
                  Else
                     If Not ctlOver.Container Is m_objParent Then
                        ' Don't do anything.
                        bSkip = True
                     End If
                  End If
               
                  If Not bSkip Then
                     On Error Resume Next
                     lhWNd = ctlOver.hwnd
                     If Err.Number <> 0 Then
                        bS = (ctlOver.Tag <> "")
                        bS = Not (bS)
                        If bS Then
                           If wParam = WM_LBUTTONDOWN Then
                              m_iSelCount = m_iSelCount + 1
                              ctlOver.Tag = ctlOver.BackColor
                              ctlOver.BackColor = &HFF00&
                              Set ctlIgnore = ctlOver
                           End If
                        Else
                           If wParam = WM_LBUTTONUP Then
                              If Not ctlIgnore Is ctlOver Then
                                 m_iSelCount = m_iSelCount - 1
                                 ctlOver.BackColor = ctlOver.Tag
                                 ctlOver.Tag = ""
                              End If
                              Set ctlIgnore = Nothing
                           End If
                        End If
                     Else
                        bS = GetProp(ctlOver.hwnd, "Selected")
                        bS = Not (bS)
                        If bS Then
                           If wParam = WM_LBUTTONDOWN Then
                              m_iSelCount = m_iSelCount + 1
                              SetProp ctlOver.hwnd, "OrigBackColor",
                               ctlOver.BackColor
                              SetProp ctlOver.hwnd, "Selected", bS
                              ctlOver.BackColor = &HFF00&
                              Set ctlIgnore = ctlOver
                           End If
                        Else
                           If wParam = WM_LBUTTONUP Then
                              If Not ctlIgnore Is ctlOver Then
                                 m_iSelCount = m_iSelCount - 1
                                 lC = GetProp(ctlOver.hwnd, "OrigBackColor")
                                 ctlOver.BackColor = lC
                                 SetProp ctlOver.hwnd, "Selected", bS
                              End If
                              Set ctlIgnore = Nothing
                           End If
                        End If
                     End If
                     If m_iSelCount = 0 Then
                        Set m_objParent = Nothing
                     End If
                  End If
               End If
            End If
         End If
      End Select
      
   End With
End Function