Detecting when mouse has left userform

B

bradyboyy88

Well-known Member
Joined
Feb 25, 2015
Messages
562
Is there a way to determine if the mouse has left the userform? I currently have buttons on the edge of my userform and they have mousemove events to highlight them when hovered. The problem is if the cursor goes off the userform from the edge then they stay hovered since no userform_mousemove event is triggered which uncolors them. So my question is how can i detect when the mouse leaves the userform and if this is not possible then maybe there is a better way to determine if the mouse is not hovering over the button anymore?
 
Sort by date Sort by votes
I apologize. I am an idiot and needed to add ByVal Button As MSForms.Label to the paremeter for the last sub.
 
Upvote 0

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
I altered one line of your code to limit the btn_click event to just my side menu such as:

Code: 
Private Sub Btn_Click()


    Dim oCtl As Control
    
    If Btn.Parent.Name = "MMCARMSFrame" Then
        For Each oCtl In Btn.Parent.Controls
            If TypeOf oCtl Is CommandButton Then
                If oCtl.Tag <> "" Then
                    oCtl.BackColor = Val(oCtl.Tag)
                End If
            End If
        Next
    Btn.BackColor = ACTIVE_COLOR
    bClicked = True
    End If
    
End Sub

My issue is when the userform first loads I need this one button to be the active color since that is the first menu item active on the screen and that macro runs on load. If I change the color manually with todolist.backcolor=&HFF& then it stays highlighted even when i click on the other menu items. I even set the tag to backcolor and still nothing. My other concern is that how does a class's btn event interact with one that already exists in the userform. For instance, this btn_click event happens in the class but I also have a click event for that buttton which does other stuff. Do they both just right one after the other?
 
Upvote 0
bradyboyy88 said:
Hey Jafaar,

I was wondering if you could help me find an approach similar to the one you posted here:

But without using the tag of the object as I use that for something else.
Click to expand...

You could store the Backolor values of the each commandbutton somewhere else like in the HelpContextId Property ..

Change the CMouseLeave class module code to this :
Code: 
Option Explicit
Public WithEvents Btn As MSForms.CommandButton

Private Type POINTAPI
        X As Long
        Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const CHILDID_SELF = &H0&
Private Const HOVER_COLOR As Long = &H80&   'Dark Red
Private Const ACTIVE_COLOR As Long = &HFF&  'Bright Red

Private bClicked As Boolean

Private Sub Btn_Click()
    Dim oCtl As Control
    
    For Each oCtl In Btn.Parent.Controls
        If TypeOf oCtl Is CommandButton Then
            If oCtl.HelpContextID <> 0 Then
                oCtl.BackColor = oCtl.HelpContextID
            End If
        End If
    Next
    Btn.BackColor = ACTIVE_COLOR
    bClicked = True

    [B][COLOR=#008000]'other code here ...[/COLOR][/B]
End Sub


Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant
    
    On Error Resume Next
    With Btn
        If .BackColor = ACTIVE_COLOR Then Exit Sub
        If .Parent.Tag = "" Then
            If .HelpContextID = 0 Then .HelpContextID = .BackColor
            If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption Or bClicked
            bClicked = False
            Call OnMouseLeave(Btn)
        End If
    End With 
End Sub

Private Sub OnMouseLeave(ByVal Button As CommandButton)
    With Button
        .Parent.Tag = ""
        If .BackColor <> ACTIVE_COLOR Then
            .Parent.TextBox1.Text = .HelpContextID
            .BackColor = .HelpContextID
        End If
    End With
 
   [B][COLOR=#008000] 'other code goes here..[/COLOR][/B]
End Sub
 
Last edited:
Upvote 0
Jaafar Tribak said:
You could store the Backolor values of the each commandbutton somewhere else like in the HelpContextId Property ..

Change the CMouseLeave class module code to this :
Code: 
Option Explicit
Public WithEvents Btn As MSForms.CommandButton

Private Type POINTAPI
        X As Long
        Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] [/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] [/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] [/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] [/URL]  If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] [/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] [/URL]  If

Private Const CHILDID_SELF = &H0&
Private Const HOVER_COLOR As Long = &H80&   'Dark Red
Private Const ACTIVE_COLOR As Long = &HFF&  'Bright Red

Private bClicked As Boolean

Private Sub Btn_Click()
    Dim oCtl As Control
    
    For Each oCtl In Btn.Parent.Controls
        If TypeOf oCtl Is CommandButton Then
            If oCtl.HelpContextID <> 0 Then
                oCtl.BackColor = oCtl.HelpContextID
            End If
        End If
    Next
    Btn.BackColor = ACTIVE_COLOR
    bClicked = True

    [B][COLOR=#008000]'other code here ...[/COLOR][/B]
End Sub


Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant
    
    On Error Resume Next
    With Btn
        If .BackColor = ACTIVE_COLOR Then Exit Sub
        If .Parent.Tag = "" Then
            If .HelpContextID = 0 Then .HelpContextID = .BackColor
            If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] [/URL]  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] [/URL] 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"][URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] [/URL]  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption Or bClicked
            bClicked = False
            Call OnMouseLeave(Btn)
        End If
    End With 
End Sub

Private Sub OnMouseLeave(ByVal Button As CommandButton)
    With Button
        .Parent.Tag = ""
        If .BackColor <> ACTIVE_COLOR Then
            .Parent.TextBox1.Text = .HelpContextID
            .BackColor = .HelpContextID
        End If
    End With
 
   [B][COLOR=#008000] 'other code goes here..[/COLOR][/B]
End Sub
Click to expand...

I did not even think of using that as a extra field. I ended up creating a collection which stores these values but your way is definitely more fluent. There is something really strange that happens. I modified your code to work for labels as well and to change the back color for them, but strangely enough this concept does not work for doing a border instead. For instance, say I were to have the hover effect be the label border activates (.borderstyle=1) then it does not work. Instead it would activate but flicker off immediately. For the labels I do not need any clicking color changes or what not as this is for a different menu. See the code below:

Rich (BB code): 
Option Explicit


Public WithEvents New_Label As MSFORMS.Label
Public WithEvents New_Textbox As MSFORMS.TextBox


Private Type POINTAPI
        X As Long
        Y As Long
End Type


#If  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #If  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    #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
#Else 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End  If


Private Const CHILDID_BORDERSTYLE = 0
Private Const HOVER_BORDERSTYLE As Long = 1  'light grey


Private bClicked As Boolean


Private Sub New_Label_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant


    On Error Resume Next
    With New_Label
        If .Parent.Tag = "" Then
            If NewControlsTag.item(New_Label.Name) = "" Then
                NewControlsTag.Remove (New_Label.Name)
                NewControlsTag.Add .BorderStyle, New_Label.Name
            End If
            If .BorderStyle <> HOVER_BORDERSTYLE Then .BorderStyle = HOVER_BORDERSTYLE
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                #If  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                #Else 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                #End  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption Or bClicked
            bClicked = False
            Call OnMouseLeave(New_Label)
        End If
    End With
 
End Sub


Private Sub OnMouseLeave(ByVal Button As MSFORMS.Label)
    Button.Parent.Tag = ""
    Button.BORDESTYLE = NewControlsTag.item(Button.Name)
End Sub
 
Upvote 0
bradyboyy88 said:
I did not even think of using that as a extra field. I ended up creating a collection which stores these values but your way is definitely more fluent. There is something really strange that happens. I modified your code to work for labels as well and to change the back color for them, but strangely enough this concept does not work for doing a border instead. For instance, say I were to have the hover effect be the label border activates (.borderstyle=1) then it does not work. Instead it would activate but flicker off immediately. For the labels I do not need any clicking color changes or what not as this is for a different menu. See the code below:
Click to expand...
The following worked for me ok ... The following class module code should highlight the labels on mouse over giving them a yellow backcolor and a borderstyle =1 without the need to store the initial backcolor or boder style values in any properties, tags or otherwise... I didn't notice any flickering you described.

1- Class module code:
Code: 
Option Explicit

Public WithEvents lbl As MSFORMS.Label

Private Type POINTAPI
        X As Long
        Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Private Const CHILDID_SELF = &H0&
Private Const HOVER_COLOR As Long = &HFFFF& [B][COLOR=#008000]'Yellow <== chenge this hover color as required.[/COLOR][/B]
Private Const HOVER_BORDERSTYLE As Long = 1  [COLOR=#008000][B]'light grey[/B][/COLOR]

Private lInitialBackColor As Long
Private lInitialBorderStyle As Long

Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant

    With lbl
        If .Parent.Tag = "" Then
            If lInitialBackColor = 0 Then lInitialBackColor = .BackColor: lInitialBorderStyle = .BorderStyle
            If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR: .BorderStyle = HOVER_BORDERSTYLE
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption
            Call OnMouseLeave(lbl)
        End If
    End With
End Sub

Private Sub OnMouseLeave(ByVal lbl As MSFORMS.Label)
    With lbl
        .Parent.Tag = ""
        .BackColor = lInitialBackColor
        .BorderStyle = lInitialBorderStyle
    End With
End Sub

2- userForm code :
Code: 
Option Explicit

Private oCol As New Collection

Private Sub UserForm_Initialize()
     Dim oCtl As Control
    Dim oClass As CMouseLeave
    For Each oCtl In Me.Controls
        If TypeOf oCtl Is MSFORMS.Label Then
            Set oClass = New CMouseLeave
            Set oClass.lbl = oCtl
            oCol.Add oClass
        End If
    Next
End Sub
 
Last edited:
Upvote 0
Jaafar Tribak said:
The following worked for me ok ... The following class module code should highlight the labels on mouse over giving them a yellow backcolor and a borderstyle =1 without the need to store the initial backcolor or boder style values in any properties, tags or otherwise... I didn't notice any flickering you described.

1- Class module code:
Code: 
Option Explicit

Public WithEvents lbl As MSFORMS.Label

Private Type POINTAPI
        X As Long
        Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Private Const CHILDID_SELF = &H0&
Private Const HOVER_COLOR As Long = &HFFFF& [B][COLOR=#008000]'Yellow <== chenge this hover color as required.[/COLOR][/B]
Private Const HOVER_BORDERSTYLE As Long = 1  [COLOR=#008000][B]'light grey[/B][/COLOR]

Private lInitialBackColor As Long
Private lInitialBorderStyle As Long

Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant

    With lbl
        If .Parent.Tag = "" Then
            If lInitialBackColor = 0 Then lInitialBackColor = .BackColor: lInitialBorderStyle = .BorderStyle
            If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR: .BorderStyle = HOVER_BORDERSTYLE
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption
            Call OnMouseLeave(lbl)
        End If
    End With
End Sub

Private Sub OnMouseLeave(ByVal lbl As MSFORMS.Label)
    With lbl
        .Parent.Tag = ""
        .BackColor = lInitialBackColor
        .BorderStyle = lInitialBorderStyle
    End With
End Sub

2- userForm code :
Code: 
Option Explicit

Private oCol As New Collection

Private Sub UserForm_Initialize()
     Dim oCtl As Control
    Dim oClass As CMouseLeave
    For Each oCtl In Me.Controls
        If TypeOf oCtl Is MSFORMS.Label Then
            Set oClass = New CMouseLeave
            Set oClass.lbl = oCtl
            oCol.Add oClass
        End If
    Next
End Sub
Click to expand...

Your code works flawlessly. I do not understand why mine was not but thank you so much. I have been wasting so much time on this lol. For the labels I have been using the transparent background property so I have not needed the backcolor change but it is usefull to have so thank you!
 
Upvote 0
Jaafar Tribak said:
The following worked for me ok ... The following class module code should highlight the labels on mouse over giving them a yellow backcolor and a borderstyle =1 without the need to store the initial backcolor or boder style values in any properties, tags or otherwise... I didn't notice any flickering you described.

1- Class module code:
Code: 
Option Explicit

Public WithEvents lbl As MSFORMS.Label

Private Type POINTAPI
        X As Long
        Y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Private Const CHILDID_SELF = &H0&
Private Const HOVER_COLOR As Long = &HFFFF& [B][COLOR=#008000]'Yellow <== chenge this hover color as required.[/COLOR][/B]
Private Const HOVER_BORDERSTYLE As Long = 1  [COLOR=#008000][B]'light grey[/B][/COLOR]

Private lInitialBackColor As Long
Private lInitialBorderStyle As Long

Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim vKid  As Variant

    With lbl
        If .Parent.Tag = "" Then
            If lInitialBackColor = 0 Then lInitialBackColor = .BackColor: lInitialBorderStyle = .BorderStyle
            If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR: .BorderStyle = HOVER_BORDERSTYLE
            .Parent.Tag = "looping"
            Do
                GetCursorPos tCurPos
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
                    Dim Ptr As LongPtr
                    CopyMemory Ptr, tCurPos, LenB(tCurPos)
                    Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                    Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                DoEvents
            Loop Until oIA.accName(CHILDID_SELF) <> .Caption
            Call OnMouseLeave(lbl)
        End If
    End With
End Sub

Private Sub OnMouseLeave(ByVal lbl As MSFORMS.Label)
    With lbl
        .Parent.Tag = ""
        .BackColor = lInitialBackColor
        .BorderStyle = lInitialBorderStyle
    End With
End Sub

2- userForm code :
Code: 
Option Explicit

Private oCol As New Collection

Private Sub UserForm_Initialize()
     Dim oCtl As Control
    Dim oClass As CMouseLeave
    For Each oCtl In Me.Controls
        If TypeOf oCtl Is MSFORMS.Label Then
            Set oClass = New CMouseLeave
            Set oClass.lbl = oCtl
            oCol.Add oClass
        End If
    Next
End Sub
Click to expand...

Hey I have been using this code for quite some time and it works great except sometimes I do draw an error at the parent.tag="" in onmousleave subroutine. Is there a way to get around not having to use the parent tag for anything? I could possibly be using that for something in my code somewhere.
 
Upvote 0
@bradyboyy88

Hey I have been using this code for quite some time and it works great except sometimes I do draw an error at the parent.tag="" in onmousleave subroutine. Is there a way to get around not having to use the parent tag for anything? I could possibly be using that for something in my code somewhere.
Click to expand...

What error do you get ?
 
Upvote 0
Hello @Jaafar Tribak
I was able to comment out for what I don't need for the commandbutton, but I cannot create code for Textbox base on the current code.

What I need is when hover mouse over a specific commandbutton or specific Textbox the code will run the first sub and when mouse leave it will run a second sub.

can you help me with this.

I also notice this code has been up since 2002, if there is a better way of doing this sine than that would be great.

As always thanks for your help.


code in Userform
VBA Code: 
Option Explicit

Private oCol As New Collection
   

Private Sub UserForm_Initialize()
Dim oCtl As Control
Dim oClass As CMouseLeave
For Each oCtl In Me.Controls
If TypeOf oCtl Is CommandButton Then
If oCtl.Name = "CommandButton1" Then
Set oClass = New CMouseLeave
Set oClass.Btn = oCtl
oCol.Add oClass
End If
' ElseIf TypeOf oCtl Is TextBox Then
' If (oCtl.Name = "TextBox1") Then
'
' End If
' Set oClass = New CMouseLeave
' Set oClass.TxtBox = oCtl
' oCol.Add oClass
' End If
Next
End Sub

code in Class Modules CMouseLeave
VBA Code: 
Option Explicit

Public WithEvents Btn As MSForms.CommandButton
Public WithEvents TxtBox As MSForms.TextBox

Private Type POINTAPI
X As Long
Y As Long
End Type

#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#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
#Else
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If

Private Const CHILDID_SELF = &H0&
Private Const HIGHLIGHT_COLOR As Long = &HFF&  'red

Dim bFirstPass As Boolean


Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Dim tCurPos As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant


On Error Resume Next

If bFirstPass = False Then
Debug.Print "enter"
bFirstPass = True
End If

With Btn
If .Parent.Tag = "" Then
'If .Tag = "" Then Btn.Tag = .BackColor
'If .BackColor <> HIGHLIGHT_COLOR Then .BackColor = HIGHLIGHT_COLOR
Do
.Parent.Tag = "looping"
GetCursorPos tCurPos
#If Win64 Then
Dim Ptr As LongPtr
CopyMemory Ptr, tCurPos, LenB(tCurPos)
Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
#Else
Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
#End If
DoEvents
Loop Until oIA.accName(CHILDID_SELF) <> .Caption
Debug.Print oIA.accName(CHILDID_SELF)
Call OnMouseLeave(Btn)
End If
End With

End Sub

Private Sub OnMouseLeave(ByVal Button As CommandButton)
' Button.BackColor = (Button.Tag)
    Button.Parent.Tag = ""

    '[COLOR=#008000]   'other code goes here..[/COLOR][/B]

If bFirstPass = True Then
Debug.Print "leave mouse"
bFirstPass = False
End If

End Sub
 
Upvote 0
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
1K
RoryA
RoryA
M
  • Solved
VBA Label Font goes Bold and Underline when moving mouse over
Replies
4
Views
2K
Domenic
D
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
W
  • Question Question
Alignment of Notes within Page Layout view
Replies
0
Views
359
wpryan
W
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
760
huiettcm
H

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top