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
 
Sort by date Sort by votes

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Re: VBA- how can i have a userform behaviours just like controltiptext?

mahhdy said:
That worked perfectly.

I am linking to a demo file for future reference.

https://1drv.ms/x/s!AoudgKyahScLhShLzRUNOK1cvTLH

Regards,
M
Click to expand...

I am glad you liked the code and that it worked for you ... Your workbook demo looks nice.

BTW, if you want to take this a little bit further and make the popup userform look more like a standard tooltip (ie: No caption, Back color , relative screen position to the control or mouse cursor etc..) I can think of a couple of workarounds.
 
Upvote 0
Re: VBA- how can i have a userform behaviours just like controltiptext?

Right now this f** app is going to be very big. I am taking care of other parts rigt now. That could be nice idea, but not now.
I just have one question, the usage of control.tag for timer purpose. can we change that to a public variable or something else? I am using the tag for another purpose. that is not a important thing, I will change that. Just wondering if you know how can I get specific property of a class instance. I mean without loop and if inside its collection. I tried to set than on an public object inside the class. But it seems the properties are not attaching to that.

I also added your answer to this stackoverflow question, linking your post. ;)
https://stackoverflow.com/questions...-and-close-another-userform/50420163#50420163

Thanks a lot again.
Cheers,
M

Jaafar Tribak said:
I am glad you liked the code and that it worked for you ... Your workbook demo looks nice.

BTW, if you want to take this a little bit further and make the popup userform look more like a standard tooltip (ie: No caption, Back color , relative screen position to the control or mouse cursor etc..) I can think of a couple of workarounds.
Click to expand...
 
Upvote 0
Re: VBA- how can i have a userform behaviours just like controltiptext?

mahhdy said:
Right now this f** app is going to be very big. I am taking care of other parts rigt now. That could be nice idea, but not now.
I just have one question, the usage of control.tag for timer purpose. can we change that to a public variable or something else? I am using the tag for another purpose. that is not a important thing, I will change that. Just wondering if you know how can I get specific property of a class instance. I mean without loop and if inside its collection. I tried to set than on an public object inside the class. But it seems the properties are not attaching to that.

I also added your answer to this stackoverflow question, linking your post. ;)
https://stackoverflow.com/questions...-and-close-another-userform/50420163#50420163

Thanks a lot again.
Cheers,
M
Click to expand...

When using API calls, I try whenever possible to avoid storing values , handles etc.. in public variables in case there is an unexpected loss of state due to unhandled errors or otherwise hence loosing the contents of the variables.

In your case, if you are already using the control's Tag property for other purposes then you can use the Tag property of the main userform .. The code should look like this :

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 Object, 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 '<=== (for testing only .. edit out this line if required)

    If bFlag = False Then EnableMouseLeaveEevent = True
    
    MainUserForm.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(MainUserForm)), 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 oMainFormObj As Object, oTargetFormObj As Object
    Dim lTimeOut As Long, lStartTimer As Long
        
    CopyMemory oMainFormObj, nIDEvent, LenB(nIDEvent)
    sArray = Split(oMainFormObj.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
                               Application.ScreenUpdating = False
                               Unload oTargetFormObj
                           End If
                       Else
                            bFlag = False
                            oMainFormObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
                            GoTo Xit
                       End If
                   End With
           End If
    End If
    
Xit:
    CopyMemory oMainFormObj, 0, LenB(nIDEvent)
    CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
    GetCursorPos tPrevCurPos
End Sub
 
Upvote 0
Re: VBA- how can i have a userform behaviours just like controltiptext?

I have been working on this a bit further in an attempt to make the tooltip userform look and behave more like a standard tooltip and I have used a Class to make the use more flexible :

In case someone is interested, here is a workbook demo:

Making a userform behave like a tooltip over controls turned out to be more difficult than I expected... specially preserving the controls click event.

This is by no means perfect but it was a good learning exercise.

1- Code in a new Class Module named : ToolTipClass
Code: 
Option Explicit

Private WithEvents btn As MSForms.CommandButton
Private WithEvents lbl As MSForms.Label
Private WithEvents txtbx As MSForms.TextBox
Private WithEvents cbx As MSForms.ComboBox
Private WithEvents lbx As MSForms.ListBox
Private WithEvents frm As MSForms.Frame
Private WithEvents chckbx As MSForms.CheckBox
Private WithEvents optbtn As MSForms.OptionButton

Private lInitColor As Long
Private oMainUserForm As Object, oToolTipUserForm As Object
Private lTimeOut As Long, lFrameColor As Long, lBackColor As Long, bDropShadow As Boolean
Private lToolTipPos As ToolTipPosEnum

Public Function AttactchTo( _
    ByVal MainUserForm As Object, ByVal Ctrl As Object, ByVal TargetUserForm As Object, _
    Optional ByVal TimeOutInSeconds As Long, Optional ByVal TooltTipFrameColor As Long, _
    Optional ByVal TooltTipBackColor As Long, Optional ByVal TooltTipDropShadow As Boolean, _
    Optional ToolTipPos As ToolTipPosEnum _
) As Boolean

    Set oMainUserForm = MainUserForm
    lInitColor = TargetUserForm.BackColor

    Select Case TypeName(Ctrl)
        Case Is = "CommandButton"
            Set btn = Ctrl
        Case Is = "Label"
            Set lbl = Ctrl
        Case Is = "TextBox"
            Set txtbx = Ctrl
        Case Is = "ComboBox"
            Set cbx = Ctrl
        Case Is = "ListBox"
            Set lbx = Ctrl
        Case Is = "Frame"
            Set frm = Ctrl
        Case Is = "CheckBox"
            Set chckbx = Ctrl
        Case Is = "OptionButton"
            Set optbtn = Ctrl
    End Select
    
    Set oToolTipUserForm = TargetUserForm
    lTimeOut = TimeOutInSeconds
    lFrameColor = TooltTipFrameColor
    lBackColor = TooltTipBackColor
    bDropShadow = TooltTipDropShadow
    lToolTipPos = ToolTipPos
End Function

Private Sub Generic_MouseMove _
    (ByVal Ctrl As Object, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single _
)
 
    On Error Resume Next
        Application.Run "MouseMoveMacro", Ctrl, oToolTipUserForm, lTimeOut, lFrameColor, lBackColor, bDropShadow, lToolTipPos
    On Error GoTo 0

    If lBackColor = 0 Then lBackColor = lInitColor
    oToolTipUserForm.BackColor = lBackColor
    If EnableMouseLeaveEevent _
        (oMainUserForm, Ctrl, oToolTipUserForm, lTimeOut, lFrameColor, lBackColor, bDropShadow, lToolTipPos) Then
        oToolTipUserForm.Show
    End If
End Sub

Private Sub btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(btn, Button, Shift, X, Y)
End Sub

Private Sub cbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(cbx, Button, Shift, X, Y)
End Sub

Private Sub chckbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(chckbx, Button, Shift, X, Y)
End Sub

Private Sub frm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(frm, Button, Shift, X, Y)
End Sub

Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(lbl, Button, Shift, X, Y)
End Sub

Private Sub lbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(lbx, Button, Shift, X, Y)
End Sub

Private Sub optbtn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(optbtn, Button, Shift, X, Y)
End Sub

Private Sub txtbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Generic_MouseMove(txtbx, Button, Shift, X, Y)
End Sub

Private Sub Class_Terminate()
    Unload oToolTipUserForm '! imporatnt
End Sub

2- Code in a Standard Module :
Code: 
Option Explicit

Public Enum ToolTipPosEnum
    topleft = 1
    TopRight = 2
    Bottomleft = 3
    BottomRight = 4
    FollowMousePointer = 5
End Enum

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
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    [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
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function DrawMenuBar Lib "User32.dll" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    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
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function DrawMenuBar Lib "User32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    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
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const GWL_STYLE = -16
Private Const GCL_STYLE = -26
Private Const WS_CAPTION = &HC00000
Private Const SWP_NOSIZE = &H1
Private Const CS_DROPSHADOW = &H20000
Private Const Xoffset = 5: Const Yoffset = 5: Const Mouseoffset = 20

Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean, bClicked As Boolean

Public Function EnableMouseLeaveEevent _
( _
    ByVal MainUserForm As Object, ByVal Ctrl As Object, ByVal ToolTipUserForm As Object, _
    Optional ByVal TimeOutInSeconds As Long, Optional ByVal ToolTipFrameColor As Long, _
    Optional ByVal ToolTipBackColor As Long, Optional ByVal ToolTipDropShadow As Boolean, _
    Optional ByVal ToolTipPos As ToolTipPosEnum _
) As Boolean

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim ToolTipHwnd As LongPtr, lStyle As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim ToolTipHwnd As Long, lStyle As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Dim W As Long, h As Long
    Dim oIA As IAccessible
  
    If bFlag = False Then EnableMouseLeaveEevent = True
    If bClicked = True Then EnableMouseLeaveEevent = False
    
    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
    WindowFromAccessibleObject ToolTipUserForm, ToolTipHwnd

    With tControlRect
        oIA.accLocation .Left, .Top, W, h, 0&
        .Right = W + .Left
        .Bottom = h + .Top
    End With
    
    lStyle = GetWindowLong(ToolTipHwnd, GWL_STYLE)
    lStyle = lStyle And (Not WS_CAPTION)
    SetWindowLong ToolTipHwnd, GWL_STYLE, lStyle
    DrawMenuBar ToolTipHwnd

    If ToolTipDropShadow Then
        SetClassLong ToolTipHwnd, GCL_STYLE, GetClassLong(ToolTipHwnd, GCL_STYLE) Or CS_DROPSHADOW
    End If
 
    MainUserForm.Tag = UpdateTag(ObjPtr(ToolTipUserForm), ToolTipFrameColor, _
    ToolTipDropShadow, TimeOutInSeconds, ToolTipPos)
    SetTimer Formhwnd, CLng(ObjPtr(MainUserForm)), 0, AddressOf TimerProc
End Function

Public Sub MouseMoveMacro(Ctrl, ToolTipForm, TimeOut, FrameColor, BackColor, DropShadow, TollTipPos)
    Static oControl As Object
    Dim oLabel As Label, sPos As String
    
    If Not oControl Is Ctrl Then
        If ToolTipForm.Controls.Count = 0 Then
            With ToolTipForm.Controls.Add("Forms.Label.1", "MyLabel")
                .Width = ToolTipForm.Width
                .Height = ToolTipForm.Height
                .Left = 0
                .Top = ToolTipForm.Height / 5
                .TextAlign = 2
                .BackStyle = 0
                .Font.Bold = True
                .Font.Size = 10
                .Visible = True
            End With
        End If
        ToolTipForm.Controls("MyLabel").Caption = "Hello from :" & vbCr & Ctrl.Name
        Cells(1, 2) = ToolTipForm.Name
        Cells(2, 2) = Ctrl.Name
        Cells(3, 2) = IIf(TimeOut = 0, "None", TimeOut)
        Cells(4, 2) = IIf(FrameColor = 0, "N/A", FrameColor)
        Cells(5, 2) = IIf(BackColor = 0, "Default Color", BackColor)
        Cells(6, 2) = DropShadow
        Select Case TollTipPos
                Case Is = topleft
            sPos = "Topleft"
                Case Is = TopRight
            sPos = "TopRight"
                Case Is = Bottomleft
            sPos = "Bottomleft"
                 Case Is = BottomRight
            sPos = "BottomRight"
                Case Is = FollowMousePointer
            sPos = "FollowMousePointer"
                Case Else
            sPos = "N/A"
        End Select
        Cells(7, 2) = sPos
    End If
    Set oControl = Ctrl
End Sub

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

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hdc As LongPtr, hBrush As LongPtr, lToolTipHwnd As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hdc As Long, hBrush As Long, lToolTipHwnd As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Static tPrevCurPos As POINTAPI
    Dim tToolTipFormRect As RECT
    Dim tCurPos As POINTAPI
    Dim sArray() As String
    Dim oMainFormObj As Object, oTargetFormObj As Object, oIA As IAccessible
    Dim lTimeOut As Long, lStartTimer As Long
    Dim lTooltTipFrameColor As Long, lTooltTipDropShadow As Long
    Dim l As Long, t As Long, lPos As Long
    
    On Error Resume Next
   
    CopyMemory oMainFormObj, nIDEvent, LenB(nIDEvent)
    sArray = Split(oMainFormObj.Tag, "*")
    CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
    If IsNumeric(sArray(1)) Then lTooltTipFrameColor = CLng(sArray(1))
    If IsNumeric(sArray(2)) Then lTooltTipDropShadow = CLng(sArray(2))
    If IsNumeric(sArray(3)) Then lTimeOut = CLng(sArray(3))
    If IsNumeric(sArray(4)) Then lStartTimer = CLng(sArray(4))
    If IsNumeric(sArray(5)) Then lPos = CLng(sArray(5))

    GetCursorPos tCurPos
    [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
            Dim lPtr As LongPtr
            CopyMemory lPtr, tCursPos, LenB(tCursPos)
            Call AccessibleObjectFromPoint(lPtr, 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] 
        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
        
    Call GetAsyncKeyState(vbKeyLButton)
    If GetAsyncKeyState(vbKeyLButton) Then
        bClicked = True
        oTargetFormObj.Hide
        oIA.accDoDefaultAction 0&
        oIA.accSelect 1, 0&
    End If
        
    If GetAsyncKeyState(vbKeyEscape) Then
        bClicked = True
        oTargetFormObj.Hide
    End If

     WindowFromAccessibleObject oTargetFormObj, lToolTipHwnd
     If IsWindowVisible(lToolTipHwnd) Then
         GetWindowRect lToolTipHwnd, tToolTipFormRect
         With tToolTipFormRect
             Select Case lPos
                 Case Is = topleft
                     l = tControlRect.Left - (.Right - .Left) - Xoffset
                     t = tControlRect.Top - (.Bottom - .Top) - Yoffset
                 Case Is = TopRight
                     l = tControlRect.Right + Xoffset
                     t = tControlRect.Top - (.Bottom - .Top) - Yoffset
                 Case Is = Bottomleft
                     l = tControlRect.Left - (.Right - .Left) - Xoffset
                     t = tControlRect.Bottom + Yoffset
                 Case Is = BottomRight
                     l = tControlRect.Right + Xoffset
                     t = tControlRect.Bottom + Yoffset
                 Case Is = FollowMousePointer
                     l = tCurPos.X + Mouseoffset
                     t = tCurPos.Y + Mouseoffset
                 Case Else
                     GoTo SetFrame
             End Select
         End With
         SetWindowPos lToolTipHwnd, -1, l, t, 0, 0, SWP_NOSIZE
SetFrame:
         If lTooltTipFrameColor Then
             GetWindowRect lToolTipHwnd, tToolTipFormRect
             hBrush = CreateSolidBrush(lTooltTipFrameColor)
             hdc = GetDC(0)
             FrameRect hdc, tToolTipFormRect, hBrush
             ReleaseDC 0, hdc
             DeleteObject hBrush
         End If
    End If
   
    If lTooltTipDropShadow Then
        Call SetClassLong(lToolTipHwnd, GCL_STYLE, CS_DROPSHADOW)
    End If
     
    [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, tCurPos, LenB(tCurPos)
            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, tCurPos.X, tCurPos.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, tCurPos.X, tCurPos.Y) = 0 Then
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
            bFlag = False
            bClicked = False
            KillTimer hwnd, nIDEvent
            If lTooltTipDropShadow Then
              SetClassLong lToolTipHwnd, GCL_STYLE, GetClassLong(lToolTipHwnd, GCL_STYLE) And Not CS_DROPSHADOW
            End If
            oTargetFormObj.Hide
            'Debug.Print "Cursor moved outside control!"
        Else
           If lTimeOut > 0 Then
                   With tCurPos
                       If .X = tPrevCurPos.X And .Y = tPrevCurPos.Y Then
                           If Timer - lStartTimer > lTimeOut Then
                               bFlag = True
                               bClicked = False
                               lStartTimer = Timer
                               KillTimer hwnd, nIDEvent
                               If lTooltTipDropShadow Then
                                 SetClassLong lToolTipHwnd, GCL_STYLE, _
                                 GetClassLong(lToolTipHwnd, GCL_STYLE) And Not CS_DROPSHADOW
                               End If
                                oTargetFormObj.Hide
                                'Debug.Print "timeout!"
                           End If
                       Else
                            bFlag = False
                            oMainFormObj.Tag = _
                            UpdateTag(ObjPtr(oTargetFormObj), lTooltTipFrameColor, lTooltTipDropShadow, _
                            lTimeOut, lPos)
                       End If
                   End With
           End If
    End If
    
Xit:
    CopyMemory oMainFormObj, 0, LenB(nIDEvent)
    CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
    GetCursorPos tPrevCurPos
End Sub

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function UpdateTag(ByVal pFrmPointer As LongPtr, ByVal FrameColor As Long, _
    ByVal shadow As Boolean, TimeOut As Long, ByVal TipPos As Long) As String
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function UpdateTag(ByVal pFrmPointer As Long, ByVal FrameColor As Long, _
    ByVal shadow As Boolean, TimeOut As Long, ByVal TipPos As Long) As String
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    UpdateTag = pFrmPointer & "*"
    If FrameColor = 0 Then UpdateTag = UpdateTag & "-" & "*" Else UpdateTag = UpdateTag & FrameColor & "*"
    If shadow = False Then UpdateTag = UpdateTag & "-" & "*" Else UpdateTag = UpdateTag & CLng(shadow) & "*"
    If TimeOut < 1 Then UpdateTag = UpdateTag & "-" & "*" & "-" & "*" Else UpdateTag = UpdateTag & TimeOut & "*" & Timer & "*"
    If TipPos = 0 Then UpdateTag = UpdateTag & "-" & "*" Else UpdateTag = UpdateTag & CLng(TipPos) & "*"
    UpdateTag = UpdateTag
End Function

3- Code usage in the Userform1 Module :
Code: 
Option Explicit

Private oCol As New Collection

Private Sub UserForm_Initialize()
    Dim btn1ToolTip As New ToolTipClass
    Dim btn2ToolTip As New ToolTipClass
    Dim btn3ToolTip As New ToolTipClass
    Dim btn4ToolTip As New ToolTipClass
    Dim lblToolTip As New ToolTipClass
    Dim txtbxTollTip As New ToolTipClass
    Dim optbtn1TollTip1 As New ToolTipClass
    Dim optbtn1TollTip2 As New ToolTipClass
 
    btn1ToolTip.AttactchTo Me, CommandButton1, UserForm2, 4, , , False, topleft
    oCol.Add btn1ToolTip
    
    btn2ToolTip.AttactchTo Me, CommandButton2, UserForm2, , vbGreen, vbWhite, , TopRight
    oCol.Add btn2ToolTip
    
    btn3ToolTip.AttactchTo Me, CommandButton3, UserForm2, 0, , vbRed, True, Bottomleft
    oCol.Add btn3ToolTip
    
    btn4ToolTip.AttactchTo Me, CommandButton4, UserForm2, 5, 4, vbYellow, True, BottomRight
    oCol.Add btn4ToolTip
    
    lblToolTip.AttactchTo Me, Label1, UserForm2, 3, , vbMagenta, True
    oCol.Add lblToolTip
    
    txtbxTollTip.AttactchTo Me, TextBox1, UserForm2, 2, vbCyan, RGB(200, 10, 80), True, BottomRight
    oCol.Add txtbxTollTip
    
    optbtn1TollTip1.AttactchTo Me, OptionButton1, UserForm2, 2, vbCyan, RGB(100, 100, 200), True, FollowMousePointer
    oCol.Add optbtn1TollTip1
    
    optbtn1TollTip2.AttactchTo Me, OptionButton2, UserForm2, 2, vbWhite, vbCyan, True, FollowMousePointer
    oCol.Add optbtn1TollTip2
End Sub

Private Sub UserForm_Terminate()
    Set oCol = Nothing
End Sub

Private Sub CommandButton1_Click()
    MsgBox "Click Test"
End Sub

Private Sub CommandButton2_Click()
    MsgBox "Click Test"
End Sub
 
Last edited:
Upvote 0
Re: VBA- how can i have a userform behaviours just like controltiptext?

Hi,
This was awesome... Great job.
for the Attachto me... I always was thinking this should be the way of assigning to the classes. Not repetitive several lines and declarations....

Thanks a lot
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Show Tag of a Commandbutton in an Excel sheet (Vba Macro)
2
Replies
11
Views
243
Joe4
Joe4
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
381
huiettcm
H
M
  • Solved
VBA Label Font goes Bold and Underline when moving mouse over
Replies
4
Views
1K
Domenic
D
C
  • Question
Excel VBA- Viewing and Updating existing worksheet data with Excel UserForm with Dependent Comboboxes
Replies
2
Views
867
charliechaz
C
D
  • Question
excel userform problems after january 2023 security update?
Replies
0
Views
1K
donalde
D

Forum statistics

Threads
1,216,119
Messages
6,128,947
Members
449,480
Latest member
yesitisasport

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