VBA- how can i have a userform behaviours just controltiptext?

M

mahhdy

Board Regular
Joined
Sep 15, 2016
Messages
86
Hello,
Actually, I need a small userform to pops up after mouse over and disappearing after mouse leaves the control. Is there any way for that, or any workaround this? now I am using a userform + application.ontimecommand to close that form after 2 seconds, but this does not look good at all, I assume.

Thanks for your help.
regards,
M
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
I'm working with Excel for Mac, which doesn't support modeless userforms.
And the problem with that is that the focus goes to the second userform, so that the "mouse leaves the control (on the first form)" can't be detected.
So the second userform has a command button to close it. That command button has its Default property set to True so that pressing return dismisses the second form.

Code: 
' in first userform

Dim startHover As Double
Dim HoverDone As Boolean

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Not HoverDone Then
        If startHover = 0 Then
            startHover = Timer
        Else
            If Timer - startHover > 0.5 Then
                ShowHoverForm Me.Left + x + 50, Me.Top + y + 100
                startHover = 0
                HoverDone = True
            End If
        End If
    End If
End Sub

Private Sub ShowHoverForm(suLeft As Single, suTop As Single)
    With UserForm2
        .suLeft = suLeft
        .suTop = suTop
        .Show
    End With
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    startHover = 0
    HoverDone = False
End Sub

Code: 
' in second userform

Public suLeft As Single
Public suTop As Single

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Me.Left = suLeft
    Me.Top = suTop
End Sub

Private Sub UserForm_Initialize()
    suLeft = 500
    suTop = 300
    Me.CommandButton1.Default = True
End Sub
 
Upvote 0
Thanks, Mike,

I have something which works, But I know that is not a clean way to do that. Anyway, I also added a hidden frame to my main form which will be visible on mouse move.

Here is my code:
This even on a class module will show the second userform of CurrentJob
Code: 
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
    ByVal X As Single, ByVal Y As Single)
    Dim m, n&
    If Button = XlMouseButton.xlPrimaryButton And MainMap.Edit.Caption = "Done" Then
        Label1.Left = Label1.Left + X - x_offset
        Label1.Top = Label1.Top + Y - y_offset
    ElseIf MainMap.Edit.Caption = "Go to Edit Mode" Then
            With MainMap.Frame1
                .Visible = True
                .WorkerN = Label1.Caption
                .LBcurr = openJobs
                .LClsd = WorksheetFunction.CountIfs(oprecord.Range("e:e"), Label1.Caption, oprecord.Range("f:f"), Date, oprecord.Range("s:s"), "CLOSED")
            End With
'if wanted to use the separeate form
        If MainMap.TglB1 And Not CurrentJob.Visible Then
            With CurrentJob
                .Caption = "Current Job of " & Label1.Caption
                .LCurr = openJobs
                .LLast = LastJob
                .LClsd = WorksheetFunction.CountIfs(oprecord.Range("e:e"), Label1.Caption, oprecord.Range("f:f"), Date, oprecord.Range("s:s"), "CLOSED")
                n = Right(Label1.Tag, Len(Label1.Tag) - 1)
                .LAc = IIf(n > 288, "N/A", Fix((n - 1) / 24) + 70006)
                m = WorksheetFunction.VLookup(Label1.Caption, rooster.Range("b:e"), 4, 0)
                .LSkill = Right(m, Len(m) - InStr(1, m, " "))
                .StartUpPosition = 0
                .Top = IIf(Label1.Top > MainMap.Height / 2, Label1.Top - .Height, Label1.Top + Label1.Height)
                .Left = IIf(Label1.Left > MainMap.Width / 2, Label1.Left - .Width, Label1.Left + Label1.Width)
                .Show
            End With
        End If
' separate form code ends here
    End If
End Sub

Also on the second form:
Code: 
Private Sub UserForm_Activate()
    ontime = True
    Application.ontime Now + TimeValue("00:00:01"), "closeee", Now + TimeValue("00:00:07")

End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'On Error Resume Next
    ontime = False
    x1 = X
    y1 = Y
    mouseleft Me
End Sub

and also in another module

Code: 
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Sub closeee()
    If ontime And CurrentJob.Visible Then
        CurrentJob.Hide
        ontime = False
    End If
End Sub

Sub mouseleft(Optional ByRef frm As Object)
Dim CurPos As POINTAPI, h1&, w1&
    GetCursorPos CurPos
    If frm Is Nothing Then
        h1 = 0
        w1 = 0
    Else
        With frm
            h1 = .Height
            w1 = .Width
        End With
    End If
    Do While CurPos.X <= x1 + h1 And CurPos.Y <= y1 + w1 And CurPos.X > x1 And CurPos.Y > y1
    frm.Visible = True
    DoEvents
    Loop
    If frm.Visible Then frm.Hide
    
End Sub

I also used one of the class codes to detect when mouse left the labels in my class. (all of my labels for the above-mentioned class are Run Time generated ones.)

Have a wonderful day,
M
 
Upvote 0
Again,
I have also another idea, which can make your workaround more plausible. How we can just open the second form when the mouse is over that control for a specific time i.e 1 sec. If so we can assume he/ she wanted that detail and he/ she needs to close that manually or the second from became close when he/ she left the form intentionally.
 
Upvote 0
Please take a minute to read the forum rules, especially regarding cross-posting, and then add the relevant links here to your posts in other forums. Thanks.
 
Upvote 0
I don't like the idea of a 1 second window. If I'm looking for additional information, I want that information to stay put until I'm done with it, possibly longer than 1 second. If the custom tool tip text is just a stock reminder, then the existing tool tip should be sufficient.

This shows how to display a Frame (with a Label in it). This shows for one TextBox, but by passing arguments to the ShowHover routine, it can be customized for every control that you want. (Also if TextBox1 is in a Frame or a Multipage that control's MouseMove event has to match the Userform_MouseMove code.)

Code: 
' in first userform

Dim startHover As Double
Dim HoverDone As Boolean

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Not HoverDone Then
        If startHover = 0 Then
            startHover = Timer
        Else
            If Timer - startHover > 0.5 Then
                With TextBox1
                    ShowHoverForm suLeft:=.Left + .Width, suTop:=.Top + .Height, myMessage:="TB1 hover"
                End With
            End If
        End If
    End If
End Sub

Private Sub ShowHoverForm(suLeft As Single, suTop As Single, myMessage As String)
    With Frame1
        .Left = suLeft
        .Top = suTop
        .Label1.Caption = myMessage
        .Visible = True
    End With
End Sub

Private Sub UserForm_Initialize()
    Frame1.Visible = False
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Frame1.Visible = False
    startHover = 0
    HoverDone = False
End Sub
 
Upvote 0
Give this a try and see if it works for you :

1- In a Standard Module:
Code: 
Option Explicit

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) 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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Private tCursPos As POINTAPI, tControlRect As RECT

Public Sub EnableMouseLeaveEvent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object)
    Dim oIA As IAccessible
    Dim w As Long, h As Long
    
    TargetUserForm.StartUpPosition = 0 [B][COLOR=#008000]'<=== (for testing only .. edit out this line if required)[/COLOR][/B]
    
    Ctrl.Tag = ObjPtr(TargetUserForm)
    GetCursorPos tCursPos
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim Formhwnd As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
            Dim lngPtr As LongPtr
            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
            Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            Call AccessibleObjectFromPoint(tCursPos.X, tCursPos.Y, oIA, 0)
        [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] 
        Dim Formhwnd As Long
        Call AccessibleObjectFromPoint(tCursPos.X, tCursPos.Y, oIA, 0)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
    WindowFromAccessibleObject MainUserForm, Formhwnd
    With tControlRect
        oIA.accLocation .Left, .Top, w, h, 0&
        .Right = w + .Left
        .Bottom = h + .Top
    End With
    
    SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Sub

Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim oCtrolObj As Object
    Dim oTargetFormObj As Object
    
    On Error Resume Next
'    If IsWindow(hwnd) = 0 Then KillTimer hwnd, nIDEvent: MsgBox "jhjk": Exit Sub
    
    CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
    CopyMemory oTargetFormObj, CLng(oCtrolObj.Tag), LenB(nIDEvent)
    GetCursorPos tCursPos
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim lngPtr As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
            If PtInRect(tControlRect, lngPtr) = 0 Then
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            If PtInRect(tControlRect, tCursPos.X, tCursPos.Y) = 0 Then
        [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] 
        Dim lngPtr As Long
        If PtInRect(tControlRect, tCursPos.X, tCursPos.Y) = 0 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
        KillTimer hwnd, nIDEvent
        Unload oTargetFormObj
        Debug.Print "Mouse Cursor outside button!"
        GoTo Xit
    End If
    
Xit:
    CopyMemory oCtrolObj, 0, LenB(nIDEvent)
    CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
End Sub

Then you can test the above code on CommandButton1 as follows :

2-Code in the Main Userform Module :
Code: 
Option Explicit

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call EnableMouseLeaveEvent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2)
    UserForm2.Show
End Sub

You can do the same with any other control .. just pass a reference to the actual control in the second argument of the EnableMouseLeaveEvent routine.

Should work with Modal as well as Modeless userfoms.
 
Upvote 0
Here is a better and more flexible version of my above code which will now allow you to optionally make the tooltip-like userform auto-close after X number of seconds .

So now the tooltip userform should automatically colse either by leaving the commandbutton with the mouse as per my previous code or by expiring the timeout after mouse inactivity over the commandbutton - Whichever happens first.

For this, I have converted the EnableMouseLeaveEvent from a Sub to a Function and have added to it a 4th optional argument to hold the number of seconds timeout.

1- Code in a Standard module:
Code: 
Option Explicit

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) 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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean

Public Function EnableMouseLeaveEevent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object, Optional ByVal TimeOutInSeconds As Long) As Boolean
    Dim oIA As IAccessible
    Dim w As Long, h As Long

    TargetUserForm.StartUpPosition = 0[B][COLOR=#008000] '<=== (for testing only .. edit out this line if required)[/COLOR][/B]

    If bFlag = False Then EnableMouseLeaveEevent = True
    
    Ctrl.Tag = IIf(TimeOutInSeconds > 0, ObjPtr(TargetUserForm) & "*" & TimeOutInSeconds & "*" & Timer, ObjPtr(TargetUserForm))
    GetCursorPos tCursPos
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim Formhwnd As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
            Dim lngPtr As LongPtr
            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
            Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
        [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] 
        Dim Formhwnd As Long
        Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
    WindowFromAccessibleObject MainUserForm, Formhwnd
    
    With tControlRect
        oIA.accLocation .Left, .Top, w, h, 0&
        .Right = w + .Left
        .Bottom = h + .Top
    End With
    
    SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Function

Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)

    Static tPrevCurPos As POINTAPI
    Dim tCurrCurPos As POINTAPI
    Dim sArray() As String
    Dim oCtrolObj As Object, oTargetFormObj As Object
    Dim lTimeOut As Long, lStartTimer As Long
    
    CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
    sArray = Split(oCtrolObj.Tag, "*")
    CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
    
    If UBound(sArray) = 2 Then
        lTimeOut = CLng(sArray(1))
        lStartTimer = CLng(sArray(2))
    End If
    
    GetCursorPos tCurrCurPos
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim lngPtr As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
            CopyMemory lngPtr, tCurrCurPos, LenB(tCurrCurPos)
            If PtInRect(tControlRect, lngPtr) = 0 Then
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
        [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] 
        Dim lngPtr As Long
        If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
            bFlag = False
            KillTimer hwnd, nIDEvent
            Unload oTargetFormObj
            Debug.Print "Mouse Cursor outside button!"
            GoTo Xit
        Else
           If lTimeOut > 0 Then
                   With tCurrCurPos
                       If .x = tPrevCurPos.x And .y = tPrevCurPos.y Then
                           If Timer - lStartTimer > lTimeOut Then
                               bFlag = True
                               lStartTimer = Timer
                               KillTimer hwnd, nIDEvent
                               Unload oTargetFormObj
                               Debug.Print "TimeOut!"
                           End If
                       Else
                            bFlag = False
                            oCtrolObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
                            GoTo Xit
                       End If
                   End With
           End If
    End If
    
Xit:
    CopyMemory oCtrolObj, 0, LenB(nIDEvent)
    CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
    GetCursorPos tPrevCurPos
End Sub

2- Code usage in UserForm Module:
Code: 
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    If EnableMouseLeaveEevent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2, TimeOutInSeconds:=5) Then [B][COLOR=#008000]' 5 Sec timeout[/COLOR][/B]
        UserForm2.Show
    End If
    
End Sub
 
Upvote 0
Wowwwww

This is perfect.

Actually, I already used one of your other codes in some part of my app. But this one was perfect and neat. I will embed that in my app and will share the feed back. But I think I rather to join the idea of delayed pop up with this as well. My User form is so busy and labels are attached to each other. But who knows... I will test them all.

Regards,
M


Jaafar Tribak said:
Here is a better and more flexible version of my above code which will now allow you to optionally make the tooltip-like userform auto-close after X number of seconds .

So now the tooltip userform should automatically colse either by leaving the commandbutton with the mouse as per my previous code or by expiring the timeout after mouse inactivity over the commandbutton - Whichever happens first.

For this, I have converted the EnableMouseLeaveEvent from a Sub to a Function and have added to it a 4th optional argument to hold the number of seconds timeout.

1- Code in a Standard module:
Code: 
Option Explicit

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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    [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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) 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
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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 PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
 
Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean

Public Function EnableMouseLeaveEevent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object, Optional ByVal TimeOutInSeconds As Long) As Boolean
    Dim oIA As IAccessible
    Dim w As Long, h As Long

    TargetUserForm.StartUpPosition = 0[B][COLOR=#008000] '<=== (for testing only .. edit out this line if required)[/COLOR][/B]

    If bFlag = False Then EnableMouseLeaveEevent = True
    
    Ctrl.Tag = IIf(TimeOutInSeconds > 0, ObjPtr(TargetUserForm) & "*" & TimeOutInSeconds & "*" & Timer, ObjPtr(TargetUserForm))
    GetCursorPos tCursPos
    
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim Formhwnd As LongPtr
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
            Dim lngPtr As LongPtr
            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
            Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
            Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
        [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] 
        Dim Formhwnd As Long
        Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    WindowFromAccessibleObject MainUserForm, Formhwnd
    
    With tControlRect
        oIA.accLocation .Left, .Top, w, h, 0&
        .Right = w + .Left
        .Bottom = h + .Top
    End With
    
    SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Function

Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)

    Static tPrevCurPos As POINTAPI
    Dim tCurrCurPos As POINTAPI
    Dim sArray() As String
    Dim oCtrolObj As Object, oTargetFormObj As Object
    Dim lTimeOut As Long, lStartTimer As Long
    
    CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
    sArray = Split(oCtrolObj.Tag, "*")
    CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
    
    If UBound(sArray) = 2 Then
        lTimeOut = CLng(sArray(1))
        lStartTimer = CLng(sArray(2))
    End If
    
    GetCursorPos tCurrCurPos
    
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim lngPtr As LongPtr
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
            CopyMemory lngPtr, tCurrCurPos, LenB(tCurrCurPos)
            If PtInRect(tControlRect, lngPtr) = 0 Then
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
            If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
        [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] 
        Dim lngPtr As Long
        If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
            bFlag = False
            KillTimer hwnd, nIDEvent
            Unload oTargetFormObj
            Debug.Print "Mouse Cursor outside button!"
            GoTo Xit
        Else
           If lTimeOut > 0 Then
                   With tCurrCurPos
                       If .x = tPrevCurPos.x And .y = tPrevCurPos.y Then
                           If Timer - lStartTimer > lTimeOut Then
                               bFlag = True
                               lStartTimer = Timer
                               KillTimer hwnd, nIDEvent
                               Unload oTargetFormObj
                               Debug.Print "TimeOut!"
                           End If
                       Else
                            bFlag = False
                            oCtrolObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
                            GoTo Xit
                       End If
                   End With
           End If
    End If
    
Xit:
    CopyMemory oCtrolObj, 0, LenB(nIDEvent)
    CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
    GetCursorPos tPrevCurPos
End Sub

2- Code usage in UserForm Module:
Code: 
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    If EnableMouseLeaveEevent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2, TimeOutInSeconds:=5) Then [B][COLOR=#008000]' 5 Sec timeout[/COLOR][/B]
        UserForm2.Show
    End If
    
End Sub
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
87
6StringJazzer
6StringJazzer
D
  • Solved
Show Tag of a Commandbutton in an Excel sheet (Vba Macro)
2
Replies
11
Views
676
Joe4
Joe4
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
759
huiettcm
H
M
  • Solved
VBA Label Font goes Bold and Underline when moving mouse over
Replies
4
Views
2K
Domenic
D
C
  • Question Question
Excel VBA- Viewing and Updating existing worksheet data with Excel UserForm with Dependent Comboboxes
Replies
2
Views
1K
charliechaz
C

Forum statistics

Threads
1,223,888
Messages
6,175,207
Members
452,618
Latest member
Tam84

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