Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
The code doesn't rely entirely on the native MouseMove event. This so that it detects when the mouse leaves controls that overlap or those that are located at the edges of the userform... It also works on controls that are located inside Frames and Multipages... The Class as well as the pseudo-events are very easy to use by the userform.
Workbook Demo
1- Class Code (C_MouseEnterLeave)
2- Code Usage (UserForm)
Workbook Demo
1- Class Code (C_MouseEnterLeave)
VBA Code:
Option Explicit
Private Type POINTAPI
x As Long
Y As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
Private WithEvents lbl As MsForms.Label
Private WithEvents txt As MsForms.TextBox
Private WithEvents cbx As MsForms.ComboBox
Private WithEvents lbx As MsForms.ListBox
Private WithEvents chx As MsForms.CheckBox
Private WithEvents opt As MsForms.OptionButton
Private WithEvents tgl As MsForms.ToggleButton
Private WithEvents frm As MsForms.Frame
Private WithEvents cbt As MsForms.CommandButton
Private WithEvents tbs As MsForms.TabStrip
Private WithEvents mlp As MsForms.MultiPage
Private WithEvents img As MsForms.Image
Private oThis As C_MouseEnterLeave, oForm As Object
'________________________________Class Public Method__________________________________________________
Public Sub AddControl(ByVal ThisClass As C_MouseEnterLeave, ByVal Ctrl As MsForms.Control)
Set oThis = ThisClass
Set oForm = GetUserFormObject(Ctrl)
Select Case True
Case TypeOf Ctrl Is MsForms.Label
Set lbl = Ctrl
Case TypeOf Ctrl Is MsForms.TextBox
Set txt = Ctrl
Case TypeOf Ctrl Is MsForms.ComboBox
Set cbx = Ctrl
Case TypeOf Ctrl Is MsForms.ListBox
Set lbx = Ctrl
Case TypeOf Ctrl Is MsForms.CheckBox
Set chx = Ctrl
Case TypeOf Ctrl Is MsForms.OptionButton
Set opt = Ctrl
Case TypeOf Ctrl Is MsForms.ToggleButton
Set tgl = Ctrl
Case TypeOf Ctrl Is MsForms.Frame
Set frm = Ctrl
Case TypeOf Ctrl Is MsForms.CommandButton
Set cbt = Ctrl
Case TypeOf Ctrl Is MsForms.TabStrip
Set tbs = Ctrl
Case TypeOf Ctrl Is MsForms.MultiPage
Set mlp = Ctrl
Case TypeOf Ctrl Is MsForms.Image
Set img = Ctrl
End Select
End Sub
'________________________________Class Private Routines__________________________________________________
Private Sub GenericMouseMoveEvent(ByVal Ctrl As MsForms.Control, Optional ByVal Index As Long)
Const CHILDID_SELF = &H0&
Const ROLE_SYSTEM_PANE = &H10
Static bDoLooping As Boolean
Dim tCurPos As POINTAPI, oCurAcc As IAccessible, oPrevAcc As IAccessible
Dim px1 As Long, py1 As Long, pw1 As Long, ph1 As Long
Dim px2 As Long, py2 As Long, pw2 As Long, ph2 As Long
Dim sCurAccLocation As String, sPrevAccLocation As String
If bDoLooping Or oForm.Tag = "TaggedUserForm" Then Exit Sub
oForm.Tag = "TaggedUserForm"
Do
bDoLooping = True
Call GetCursorPos(tCurPos)
#If Win64 Then
Dim ptr As LongLong
Call CopyMemory(ptr, tCurPos, LenB(tCurPos))
Call AccessibleObjectFromPoint(ptr, oCurAcc, 0&)
#Else
Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.Y, oCurAcc, 0&)
#End If
Call oCurAcc.accLocation(px1, py1, pw1, ph1, CHILDID_SELF)
If Not oPrevAcc Is Nothing Then
Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
End If
sCurAccLocation = CStr(px1) & CStr(py1) & CStr(pw1) & CStr(ph1)
sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
If oPrevAcc Is Nothing And sCurAccLocation <> sPrevAccLocation Then
Call oForm.UserForm_OnControlMouseEnter(Ctrl)
End If
Set oPrevAcc = Ctrl
Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
If TypeOf Ctrl Is MsForms.MultiPage And oCurAcc.accRole(0&) = ROLE_SYSTEM_PANE Then
Set oPrevAcc = Ctrl.Pages(Ctrl.Value)
Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
End If
sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
DoEvents
Loop Until sCurAccLocation <> sPrevAccLocation
bDoLooping = False
Call oForm.UserForm_OnControlMouseLeave(Ctrl)
oForm.Tag = ""
End Sub
Private Function GetUserFormObject(ByVal Ctrl As MsForms.Control) As Object
Dim oTemp As Object
Set oTemp = Ctrl.Parent
Do While TypeOf oTemp Is MsForms.Control
Set oTemp = oTemp.Parent
DoEvents
Loop
Set GetUserFormObject = oTemp
End Function
Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(lbl)
End Sub
Private Sub txt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(txt)
End Sub
Private Sub cbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(cbx)
End Sub
Private Sub lbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(lbx)
End Sub
Private Sub chx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(chx)
End Sub
Private Sub opt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(opt)
End Sub
Private Sub tgl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(tgl)
End Sub
Private Sub frm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(frm)
End Sub
Private Sub cbt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(cbt)
End Sub
Private Sub tbs_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(tbs)
End Sub
Private Sub mlp_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(mlp, Index + 1)
End Sub
Private Sub img_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call GenericMouseMoveEvent(img)
End Sub2- Code Usage (UserForm)
VBA Code:
Option Explicit
'Jaafar Tribak @MrExcel.com on 07/09/2020
'Class Name : C_MouseEnterLeave:
'Class Only Method : AddControl(ByVal ThisClass As C_MouseEnterLeave, ByVal Ctrl As MsForms.Control)
Private Sub UserForm_Initialize()
Dim oClass As C_MouseEnterLeave
Dim oCtrl As MsForms.Control
For Each oCtrl In Me.Controls
Set oClass = New C_MouseEnterLeave
Call oClass.AddControl(ThisClass:=oClass, Ctrl:=oCtrl)
Next
End Sub
'Pseudo-Events Handlers Must Be Declared As PUBLIC !!
'=============================================
Public Sub UserForm_OnControlMouseEnter(ByVal Ctrl As MsForms.Control)
If TypeOf Ctrl Is MultiPage Then
Debug.Print "Mouse Entered ... (" & Ctrl.Name & ")" & Ctrl.Pages(Ctrl.Value).Name
Else
Debug.Print "Mouse Entered ... (" & Ctrl.Name & ")"
End If
End Sub
Public Sub UserForm_OnControlMouseLeave(ByVal Ctrl As MsForms.Control)
If TypeOf Ctrl Is MultiPage Then
Debug.Print "Mouse Left ... (" & Ctrl.Name & ")" & Ctrl.Pages(Ctrl.Value).Name
Else
Debug.Print "Mouse Left ... (" & Ctrl.Name & ")"
End If
End Sub
