Userform controls' balloon tooltips not showing in Excel 64-bit

R

rplazzotta

New Member
Joined
Oct 28, 2021
Messages
41
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Can anyone help with my BalloonToolTips class? It works in Excel 32-bit (W7 and W10) but not in Windows 10 Excel 64-bit, even though it compiles without errors.
It's old VB6 code that I've adapted for VBA (VBA only exposes hWnds for Frames and Listboxes).
So I put any controls other than the above that require a multiline "ControlTipText" in a caption-less Frame with the Userform's bordercolor and I put the control's ControlTipText in that of the Frame.
It's the only way I've found to provide multiline tooltips for such controls.

But they just don't show in Excel 64-bit. Any help would be greatly appreciated.

http://www.wot.fr/BalloonToolTipDemo.zip

Richard
 
Sort by date Sort by votes
Thank you very much for this, Jaafar. This is extremely helpful.
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Jaafar Tribak said:
Take a look at this . It will probably need some further enhancement.

The CtoolTip Class exports two methods: AddTo and Remove and it allows you to set many attributes for the tooltips_class32 control.

Perhaps, I should have used class Properties to set the tooltip attributes instead of using UDTs for storage ... Ayway, see how it goes.

BTW, this works for all controls (even they don't have a hwnd) except SpinButtons and Scrollbars both of which do not expose a mousemove event. You don't need to use container frames.

Workbook Example








1- CToolTip Class Module:
VBA Code: 
Option Explicit

Private Enum eSTYLE
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_CLOSE = &H80
End Enum

Private Enum eICON
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum

Private Type ToolTipData
    Size As Long
    Style As eSTYLE
    BackColor As Long
    SystemInfoBackColor As Boolean 'overrides BackColor
    TextColor As Long
    SystemInfoTextColor As Boolean 'overrides TextColor
    Title As String * 64
    Icon As eICON
    Text As String * 1024
    DelayTime As Long  'in Secs
    Multiline As Boolean
    BeepSound As Boolean
End Type

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

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hwnd      As LongLong
        uId       As LongLong
        cRect     As RECT
        hinst     As LongLong
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As RECT
        hinst     As Long
#End If
   lpszText  As String
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
        Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
        Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
        Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
        Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
        Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
        Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
        Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
        Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

        Private hForm As LongPtr, hToolTip As LongPtr
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
    Private hForm As Long, hToolTip As Long
#End If

Private WithEvents oForm As MSForms.UserForm

Private tGUID As GUID
Private oCtrl As Object
Private lCookie As Long
Private bTimedOut As Boolean
Private bNoTimedOut As Boolean

Private sText As String, sTitle As String
Private lStyle As eSTYLE, lIcon As eICON
Private lBkColor As Long, lTextColor As Long
Private bSysBkColor As Boolean, bSysTextColor As Boolean
Private lTimeOut As Long
Private bMultiline As Boolean, bBeep As Boolean



'_________________________________________Class Public Methods__________________________________________________

#If Win64 Then
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As LongLong)
#Else
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As Long)
#End If

    Const S_OK = 0
    Dim tTTipData As ToolTipData
 
    Set oCtrl = Ctrl
    Set oForm = GetUserFormObject(Ctrl)
    Call IUnknown_GetWindow(oForm, VarPtr(hForm))
 
    With tGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
 
    If ConnectToConnectionPoint(Me, tGUID, True, Ctrl, lCookie) = S_OK Then
        Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData))
        With tTTipData
            sText = Left(.Text, InStr(1, .Text, vbNullChar) - 1)
            sTitle = Left(.Title, InStr(1, .Title, vbNullChar) - 1)
            lStyle = .Style
            lIcon = .Icon
            lBkColor = .BackColor
            lTextColor = .TextColor
            bSysBkColor = .SystemInfoBackColor
            bSysTextColor = .SystemInfoTextColor
            lTimeOut = Int(.DelayTime)
            If lTimeOut <= 0 Then bNoTimedOut = True
            bMultiline = .Multiline
            bBeep = .BeepSound
        End With
        Call CreateToolTip
    Else
          Err.Raise Number:=vbObjectError + 513, Description:="Unable to register the mouse event listener."
    End If

End Sub

Public Sub Remove()
    Call ConnectToConnectionPoint(Nothing, tGUID, False, oCtrl, lCookie)
    Call DestroyWindow(GetProp(Application.hwnd, "ToolTip"))
    Call RemoveProp(Application.hwnd, "ToolTip")
    Set oCtrl = Nothing
    Set oForm = Nothing
End Sub

Public Sub DO_NOT_USE(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Attribute DO_NOT_USE.VB_UserMemId = -606
    Call RetrieveControlUnderMousePointer(oCtrl)
End Sub



'__________________________________________Class Private Routines__________________________________________________

Private Sub RetrieveControlUnderMousePointer(ByVal Ctrl As MSForms.Control)

    Const CHILDID_SELF = &H0&
    Const ROLE_SYSTEM_PANE = &H10
 
    Static bDoLooping As Boolean
 
    Dim tCurPos As POINTAPI, oCurAcc As IAccessible, oPrevAcc As IAccessible
    Dim px1 As Long, py1 As Long, pw1 As Long, ph1 As Long
    Dim px2 As Long, py2 As Long, pw2 As Long, ph2 As Long
    Dim sCurAccLocation As String, sPrevAccLocation As String
    Dim t As Single
 
    t = Timer

    If bDoLooping Then Exit Sub

    Do

        If bNoTimedOut = False Then
            If Int(Timer - t) >= lTimeOut Or bTimedOut = True Then bTimedOut = True: Exit Do
        End If
 
        bDoLooping = True
        Call GetCursorPos(tCurPos)
   
        #If Win64 Then
            Dim ptr As LongLong
            Call CopyMemory(ptr, tCurPos, LenB(tCurPos))
            Call AccessibleObjectFromPoint(ptr, oCurAcc, 0&)
        #Else
            Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oCurAcc, 0&)
        #End If
       
        Call oCurAcc.accLocation(px1, py1, pw1, ph1, CHILDID_SELF)
        If Not oPrevAcc Is Nothing Then
            Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        End If
     
        sCurAccLocation = CStr(px1) & CStr(py1) & CStr(pw1) & CStr(ph1)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
   
        If oPrevAcc Is Nothing And sCurAccLocation <> sPrevAccLocation Then
               Call UpdateToolTip(px1, py1, pw1, ph1)
        End If
     
        Set oPrevAcc = Ctrl
        Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)

        DoEvents
    Loop Until sCurAccLocation <> sPrevAccLocation

    bDoLooping = False
 
    Call HideToolTip

End Sub

Private Function GetUserFormObject(ByVal Ctrl As MSForms.Control) As Object

    Dim oTemp As Object
 
    Set oTemp = Ctrl.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
        DoEvents
    Loop
    Set GetUserFormObject = oTemp
 
End Function

Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_LINK_CLASS = &H8000&
 
    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_LINK_CLASS
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP Or lStyle, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
 
End Sub


Private Sub UpdateToolTip(ByVal px As Long, ByVal py As Long, ByVal pw As Long, ByVal ph As Long)

    Const WM_USER = &H400
    Const TTF_TRACK = &H20
    Const TTF_TRANSPARENT = &H100
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_UPDATETIPTEXT = (WM_USER + 12)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_UPDATE = (WM_USER + 29)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
    Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
    Const COLOR_INFOBK = 24
    Const COLOR_INFOTEXT = 23
 
    Dim tToolInfo As TOOLINFO
 
    hToolTip = FindWindow("tooltips_class32", "MyToolTip")
    If hToolTip Then
        With tToolInfo
            .cbSize = LenB(tToolInfo)
            .hwnd = hForm
            .uFlags = TTF_TRACK Or TTF_TRANSPARENT
            .lpszText = sText
        End With
        Call SendMessageAny(hToolTip, TTM_SETTITLEA, lIcon, ByVal sTitle)
        Call SendMessageAny(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(px + pw - 10), CInt(py + ph - 10)))
        Call SendMessage(hToolTip, TTM_SETMAXTIPWIDTH, 0&, ByVal IIf(bMultiline, 1, -1))
        Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, IIf(bSysTextColor, GetSysColor(COLOR_INFOTEXT), lTextColor), 0)
        Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, IIf(bSysBkColor, GetSysColor(COLOR_INFOBK), lBkColor), 0)
        Call SendMessageAny(hToolTip, TTM_UPDATETIPTEXT, 0, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_UPDATE, 0, 0)
        Call SetProp(Application.hwnd, "ToolTip", hToolTip)
        If bBeep Then Beep
    End If

End Sub

Private Sub HideToolTip()
    Call ShowWindow(GetProp(Application.hwnd, "ToolTip"), 0)
End Sub

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Sub oForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    bTimedOut = False
End Sub



2- Code Usage example: (I the Userform module)
VBA Code: 
Option Explicit

Private Enum eSTYLE
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_CLOSE = &H80
End Enum

Private Enum eICON
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum

Private Type ToolTipData
    Size As Long
    Styles As eSTYLE
    BackColor As Long
    SystemInfoBackColor As Boolean 'overrides BackColor
    TextColor As Long
    SystemInfoTextColor As Boolean 'overrides TextColor
    Title As String * 64
    Icon As eICON
    Text As String * 1024
    DelayTime As Long  'in Seconds
    Multiline As Boolean
    BeepSound As Boolean
End Type

Private uTTData1 As ToolTipData
Private uTTData2 As ToolTipData
Private uTTData3 As ToolTipData
Private uTTData4 As ToolTipData
 
Private oCol As Collection


Private Sub UserForm_Initialize()

    Dim oCtrl As MSForms.Control
    Dim oToolTip As CToolTip
 
    Set oCol = New Collection

    'CommandButton1
    With uTTData1
        .Size = LenB(uTTData1)
        .Text = "&bla bla blah blah blah bla bla blah blah blah  ! " & vbNullChar
        .Title = CommandButton1.Name & vbNullChar
        .Styles = TTS_ALWAYSTIP + TTS_BALLOON + TTS_NOPREFIX
        .Icon = TTI_INFO
        .SystemInfoBackColor = True
        .SystemInfoTextColor = True
        .DelayTime = 4  'secs
    End With
    Set oToolTip = New CToolTip
    oCol.Add oToolTip
    Call oToolTip.AddTo(Ctrl:=CommandButton1, DataPtr:=VarPtr(uTTData1))
 
    'CommandButton2
    With uTTData2
        .Size = LenB(uTTData2)
        .Text = "Bye!" & vbNullChar
        .Title = CommandButton2.Caption & vbNullChar
        .Styles = TTS_ALWAYSTIP + TTS_NOPREFIX
        .Icon = TTI_WARNING
        .BackColor = vbCyan
        .TextColor = vbMagenta
        .DelayTime = 4
        .BeepSound = True
    End With
    Set oToolTip = New CToolTip
    oCol.Add oToolTip
    Call oToolTip.AddTo(Ctrl:=CommandButton2, DataPtr:=VarPtr(uTTData2))

    'Frame1
    With uTTData3
        .Size = LenB(uTTData3)
        .Text = String(20, "X") & vbNewLine & String(40, "X") & vbNewLine & String(50, "X") & vbNullChar
        .Title = "Testing" & vbNullChar
        .Styles = TTS_ALWAYSTIP + TTS_NOPREFIX + TTS_BALLOON
        .Icon = TTI_ERROR
        .BackColor = vbWhite
        .TextColor = vbRed
    End With
    Set oToolTip = New CToolTip
    oCol.Add oToolTip
    Call oToolTip.AddTo(Ctrl:=Frame1, DataPtr:=VarPtr(uTTData3))

    'Remaining Controls
    For Each oCtrl In Me.Controls
        If Not (oCtrl Is CommandButton1 Or oCtrl Is CommandButton2 Or oCtrl Is Frame1) Then
        With uTTData4
            .Size = LenB(uTTData4)
            .Text = oCtrl.Name & vbNullChar
            .Title = "Hello" & vbNullChar
            .Styles = TTS_ALWAYSTIP + TTS_NOPREFIX + TTS_BALLOON
            .Icon = TTI_INFO
            .SystemInfoBackColor = True
            .SystemInfoTextColor = True
            .DelayTime = 4
        End With
        Set oToolTip = New CToolTip
        oCol.Add oToolTip
        Call oToolTip.AddTo(Ctrl:=oCtrl, DataPtr:=VarPtr(uTTData4))
        Set oToolTip = New CToolTip
        End If
    Next

End Sub

Private Sub UserForm_Terminate()
    Dim i As Long
    For i = 1 To oCol.Count
        oCol.Item(i).Remove
    Next
End Sub
Click to expand...

Thanks Jaafar, that's fantastic, I'll have a look at it tonight.

Richard
 
Upvote 0
There was a bug I overlooked in the previous code (post#30) in relation to the TTS_ Style flags .

The code in post#30 makes use of only one single toottip shared between all the controls (using a shared tooltip rather than one tooltip for each control makes things lighter and less prone to crashings ). Therefore, the style flags need to be updated with its specific attributes each time the mouse points to a different control . The code missed this important fact as it was setting the style flags only once during the creation of the tooltip for the first control.

Workbook Update

So please, ignore the previous code and use the following code update with the necessary corrections.

CToolTip Class code:
VBA Code: 
Option Explicit

Private Enum eSTYLE
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_CLOSE = &H80
End Enum

Private Enum eICON
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum

Private Type ToolTipData
    Size As Long
    Style As eSTYLE
    BackColor As Long
    SystemInfoBackColor As Boolean 'overrides BackColor
    TextColor As Long
    SystemInfoTextColor As Boolean 'overrides TextColor
    Title As String * 64
    Icon As eICON
    Text As String * 1024
    DelayTime As Long  'in Secs
    Multiline As Boolean
    BeepSound As Boolean
End Type

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

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hwnd      As LongLong
        uId       As LongLong
        cRect     As Rect
        hinst     As LongLong
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As Rect
        hinst     As Long
#End If
   lpszText  As String
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
        Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
        Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
        Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
        Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
        Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
        Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
        Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
        Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
        Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) 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 hForm As LongPtr, hToolTip As LongPtr
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) 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 hForm As Long, hToolTip As Long
#End If

Private WithEvents oForm As MSForms.UserForm

Private tGUID As GUID
Private oCtrl As Object
Private lCookie As Long
Private bTimedOut As Boolean
Private bNoTimedOut As Boolean

Private sText As String, sTitle As String
Private lStyle As eSTYLE, lIcon As eICON
Private lBkColor As Long, lTextColor As Long
Private bSysBkColor As Boolean, bSysTextColor As Boolean
Private lTimeOut As Long
Private bMultiline As Boolean, bBeep As Boolean



'_________________________________________Class Public Methods__________________________________________________

#If Win64 Then
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As LongLong)
#Else
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As Long)
#End If

    Const S_OK = 0
    Dim tTTipData As ToolTipData
  
    Set oCtrl = Ctrl
    Set oForm = GetUserFormObject(Ctrl)
    Call IUnknown_GetWindow(oForm, VarPtr(hForm))
  
    With tGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
  
    If ConnectToConnectionPoint(Me, tGUID, True, Ctrl, lCookie) = S_OK Then
        Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData))
        With tTTipData
            sText = Left(.Text, InStr(1, .Text, vbNullChar) - 1)
            sTitle = Left(.Title, InStr(1, .Title, vbNullChar) - 1)
            lStyle = .Style
            lIcon = .Icon
            lBkColor = .BackColor
            lTextColor = .TextColor
            bSysBkColor = .SystemInfoBackColor
            bSysTextColor = .SystemInfoTextColor
            lTimeOut = Int(.DelayTime)
            If lTimeOut <= 0 Then bNoTimedOut = True
            bMultiline = .Multiline
            bBeep = .BeepSound
        End With
        Call CreateToolTip
    Else
          Err.Raise Number:=vbObjectError + 513, Description:="Unable to register the mouse event listener."
    End If

End Sub

Public Sub Remove()
    Call ConnectToConnectionPoint(Nothing, tGUID, False, oCtrl, lCookie)
    Call DestroyWindow(GetProp(Application.hwnd, "ToolTip"))
    Call RemoveProp(Application.hwnd, "ToolTip")
    Set oCtrl = Nothing
    Set oForm = Nothing
End Sub

Public Sub DO_NOT_USE(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    'Attribute DO_NOT_USE.VB_UserMemId = -606
    Call RetrieveControlUnderMousePointer(oCtrl)
End Sub



'__________________________________________Class Private Routines__________________________________________________

Private Sub RetrieveControlUnderMousePointer(ByVal Ctrl As MSForms.Control)

    Const CHILDID_SELF = &H0&
 
    Static bDoLooping As Boolean
 
    Dim tCurPos As POINTAPI, oCurAcc As IAccessible, oPrevAcc As IAccessible
    Dim px1 As Long, py1 As Long, pw1 As Long, ph1 As Long
    Dim px2 As Long, py2 As Long, pw2 As Long, ph2 As Long
    Dim sCurAccLocation As String, sPrevAccLocation As String
    Dim t As Single
 
    t = Timer
    If bDoLooping Then Exit Sub

    Do

        If bNoTimedOut = False Then
            If Int(Timer - t) >= lTimeOut Or bTimedOut = True Then bTimedOut = True: Exit Do
        End If
 
        bDoLooping = True
        Call GetCursorPos(tCurPos)
  
        #If Win64 Then
            Dim ptr As LongLong
            Call CopyMemory(ptr, tCurPos, LenB(tCurPos))
            Call AccessibleObjectFromPoint(ptr, oCurAcc, CHILDID_SELF)
        #Else
            Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oCurAcc, CHILDID_SELF)
        #End If
      
        Call oCurAcc.accLocation(px1, py1, pw1, ph1, CHILDID_SELF)
        If Not oPrevAcc Is Nothing Then
            Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        End If
    
        sCurAccLocation = CStr(px1) & CStr(py1) & CStr(pw1) & CStr(ph1)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
  
        If oPrevAcc Is Nothing And sCurAccLocation <> sPrevAccLocation Then
               Call UpdateToolTip(px1, py1, pw1, ph1)
        End If
    
        Set oPrevAcc = Ctrl
        Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)

        DoEvents
    Loop Until sCurAccLocation <> sPrevAccLocation

    bDoLooping = False
 
    Call HideToolTip

End Sub
Private Function GetUserFormObject(ByVal Ctrl As MSForms.Control) As Object

    Dim oTemp As Object
 
    Set oTemp = Ctrl.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
        DoEvents
    Loop
    Set GetUserFormObject = oTemp
 
End Function

Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_LINK_CLASS = &H8000&
 
    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_LINK_CLASS
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
  
End Sub


Private Sub UpdateToolTip(ByVal pX As Long, ByVal pY As Long, ByVal pw As Long, ByVal ph As Long)

    Const WM_USER = &H400
    Const TTF_TRACK = &H20
    Const TTF_TRANSPARENT = &H100
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_UPDATETIPTEXT = (WM_USER + 12)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_UPDATE = (WM_USER + 29)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
    Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
    Const COLOR_INFOBK = 24
    Const COLOR_INFOTEXT = 23
    Const GWL_STYLE = (-16)
 
    #If Win64 Then
        Dim hBrush As LongLong, hdc As LongLong
    #Else
        Dim hBrush As Long, hdc As Long
    #End If
  
    Dim tToolInfo As TOOLINFO, tClientRect As Rect
  
    hToolTip = FindWindow("tooltips_class32", "MyToolTip")
  
    If hToolTip Then
        With tToolInfo
            .cbSize = LenB(tToolInfo)
            .hwnd = hForm
            .uFlags = TTF_TRACK Or TTF_TRANSPARENT '
            .lpszText = sText
        End With
      
        Call SetWindowLong(hToolTip, GWL_STYLE, lStyle)
        Call SendMessageAny(hToolTip, TTM_SETTITLEA, lIcon, ByVal sTitle)
        Call SendMessageAny(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(pX + pw - 10), CInt(pY + ph - 10)))
        Call SendMessage(hToolTip, TTM_SETMAXTIPWIDTH, 0&, ByVal IIf(bMultiline, 1, -1))
        Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, IIf(bSysTextColor, GetSysColor(COLOR_INFOTEXT), lTextColor), 0)
        Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, IIf(bSysBkColor, GetSysColor(COLOR_INFOBK), lBkColor), 0)
        Call SendMessageAny(hToolTip, TTM_UPDATETIPTEXT, 0, tToolInfo)
        If (lStyle And TTS_BALLOON) = False Then
            Call GetClientRect(hToolTip, tClientRect)
            hdc = GetDC(hToolTip)
            hBrush = CreateSolidBrush(lTextColor)
            Call FrameRect(hdc, tClientRect, hBrush)
            Call DeleteObject(hBrush)
            Call ReleaseDC(hToolTip, hdc)
        End If
        Call SendMessageAny(hToolTip, TTM_UPDATE, 0, 0)
        Call SetProp(Application.hwnd, "ToolTip", hToolTip)
        If bBeep Then Beep
    End If

End Sub

Private Sub HideToolTip()
    Call ShowWindow(GetProp(Application.hwnd, "ToolTip"), 0)
End Sub

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Sub oForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    bTimedOut = False
End Sub


The userform code stays the same.
 
Upvote 0
Jaafar Tribak said:
There was a bug I overlooked in the previous code (post#30) in relation to the TTS_ Style flags .

The code in post#30 makes use of only one single toottip shared between all the controls (using a shared tooltip rather than one tooltip for each control makes things lighter and less prone to crashings ). Therefore, the style flags need to be updated with its specific attributes each time the mouse points to a different control . The code missed this important fact as it was setting the style flags only once during the creation of the tooltip for the first control.

Workbook Update

So please, ignore the previous code and use the following code update with the necessary corrections.

CToolTip Class code:
VBA Code: 
Option Explicit

Private Enum eSTYLE
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_CLOSE = &H80
End Enum

Private Enum eICON
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum

Private Type ToolTipData
    Size As Long
    Style As eSTYLE
    BackColor As Long
    SystemInfoBackColor As Boolean 'overrides BackColor
    TextColor As Long
    SystemInfoTextColor As Boolean 'overrides TextColor
    Title As String * 64
    Icon As eICON
    Text As String * 1024
    DelayTime As Long  'in Secs
    Multiline As Boolean
    BeepSound As Boolean
End Type

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

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hwnd      As LongLong
        uId       As LongLong
        cRect     As Rect
        hinst     As LongLong
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As Rect
        hinst     As Long
#End If
   lpszText  As String
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
        Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
        Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
        Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
        Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
        Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
        Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
        Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
        Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
        Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) 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 hForm As LongPtr, hToolTip As LongPtr
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) 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 hForm As Long, hToolTip As Long
#End If

Private WithEvents oForm As MSForms.UserForm

Private tGUID As GUID
Private oCtrl As Object
Private lCookie As Long
Private bTimedOut As Boolean
Private bNoTimedOut As Boolean

Private sText As String, sTitle As String
Private lStyle As eSTYLE, lIcon As eICON
Private lBkColor As Long, lTextColor As Long
Private bSysBkColor As Boolean, bSysTextColor As Boolean
Private lTimeOut As Long
Private bMultiline As Boolean, bBeep As Boolean



'_________________________________________Class Public Methods__________________________________________________

#If Win64 Then
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As LongLong)
#Else
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As Long)
#End If

    Const S_OK = 0
    Dim tTTipData As ToolTipData
 
    Set oCtrl = Ctrl
    Set oForm = GetUserFormObject(Ctrl)
    Call IUnknown_GetWindow(oForm, VarPtr(hForm))
 
    With tGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
 
    If ConnectToConnectionPoint(Me, tGUID, True, Ctrl, lCookie) = S_OK Then
        Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData))
        With tTTipData
            sText = Left(.Text, InStr(1, .Text, vbNullChar) - 1)
            sTitle = Left(.Title, InStr(1, .Title, vbNullChar) - 1)
            lStyle = .Style
            lIcon = .Icon
            lBkColor = .BackColor
            lTextColor = .TextColor
            bSysBkColor = .SystemInfoBackColor
            bSysTextColor = .SystemInfoTextColor
            lTimeOut = Int(.DelayTime)
            If lTimeOut <= 0 Then bNoTimedOut = True
            bMultiline = .Multiline
            bBeep = .BeepSound
        End With
        Call CreateToolTip
    Else
          Err.Raise Number:=vbObjectError + 513, Description:="Unable to register the mouse event listener."
    End If

End Sub

Public Sub Remove()
    Call ConnectToConnectionPoint(Nothing, tGUID, False, oCtrl, lCookie)
    Call DestroyWindow(GetProp(Application.hwnd, "ToolTip"))
    Call RemoveProp(Application.hwnd, "ToolTip")
    Set oCtrl = Nothing
    Set oForm = Nothing
End Sub

Public Sub DO_NOT_USE(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    'Attribute DO_NOT_USE.VB_UserMemId = -606
    Call RetrieveControlUnderMousePointer(oCtrl)
End Sub



'__________________________________________Class Private Routines__________________________________________________

Private Sub RetrieveControlUnderMousePointer(ByVal Ctrl As MSForms.Control)

    Const CHILDID_SELF = &H0&
 
    Static bDoLooping As Boolean
 
    Dim tCurPos As POINTAPI, oCurAcc As IAccessible, oPrevAcc As IAccessible
    Dim px1 As Long, py1 As Long, pw1 As Long, ph1 As Long
    Dim px2 As Long, py2 As Long, pw2 As Long, ph2 As Long
    Dim sCurAccLocation As String, sPrevAccLocation As String
    Dim t As Single
 
    t = Timer
    If bDoLooping Then Exit Sub

    Do

        If bNoTimedOut = False Then
            If Int(Timer - t) >= lTimeOut Or bTimedOut = True Then bTimedOut = True: Exit Do
        End If
 
        bDoLooping = True
        Call GetCursorPos(tCurPos)
 
        #If Win64 Then
            Dim ptr As LongLong
            Call CopyMemory(ptr, tCurPos, LenB(tCurPos))
            Call AccessibleObjectFromPoint(ptr, oCurAcc, CHILDID_SELF)
        #Else
            Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oCurAcc, CHILDID_SELF)
        #End If
     
        Call oCurAcc.accLocation(px1, py1, pw1, ph1, CHILDID_SELF)
        If Not oPrevAcc Is Nothing Then
            Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        End If
   
        sCurAccLocation = CStr(px1) & CStr(py1) & CStr(pw1) & CStr(ph1)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
 
        If oPrevAcc Is Nothing And sCurAccLocation <> sPrevAccLocation Then
               Call UpdateToolTip(px1, py1, pw1, ph1)
        End If
   
        Set oPrevAcc = Ctrl
        Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)

        DoEvents
    Loop Until sCurAccLocation <> sPrevAccLocation

    bDoLooping = False
 
    Call HideToolTip

End Sub
Private Function GetUserFormObject(ByVal Ctrl As MSForms.Control) As Object

    Dim oTemp As Object
 
    Set oTemp = Ctrl.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
        DoEvents
    Loop
    Set GetUserFormObject = oTemp
 
End Function

Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_LINK_CLASS = &H8000&
 
    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_LINK_CLASS
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
 
End Sub


Private Sub UpdateToolTip(ByVal pX As Long, ByVal pY As Long, ByVal pw As Long, ByVal ph As Long)

    Const WM_USER = &H400
    Const TTF_TRACK = &H20
    Const TTF_TRANSPARENT = &H100
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_UPDATETIPTEXT = (WM_USER + 12)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_UPDATE = (WM_USER + 29)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
    Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
    Const COLOR_INFOBK = 24
    Const COLOR_INFOTEXT = 23
    Const GWL_STYLE = (-16)
 
    #If Win64 Then
        Dim hBrush As LongLong, hdc As LongLong
    #Else
        Dim hBrush As Long, hdc As Long
    #End If
 
    Dim tToolInfo As TOOLINFO, tClientRect As Rect
 
    hToolTip = FindWindow("tooltips_class32", "MyToolTip")
 
    If hToolTip Then
        With tToolInfo
            .cbSize = LenB(tToolInfo)
            .hwnd = hForm
            .uFlags = TTF_TRACK Or TTF_TRANSPARENT '
            .lpszText = sText
        End With
     
        Call SetWindowLong(hToolTip, GWL_STYLE, lStyle)
        Call SendMessageAny(hToolTip, TTM_SETTITLEA, lIcon, ByVal sTitle)
        Call SendMessageAny(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(pX + pw - 10), CInt(pY + ph - 10)))
        Call SendMessage(hToolTip, TTM_SETMAXTIPWIDTH, 0&, ByVal IIf(bMultiline, 1, -1))
        Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, IIf(bSysTextColor, GetSysColor(COLOR_INFOTEXT), lTextColor), 0)
        Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, IIf(bSysBkColor, GetSysColor(COLOR_INFOBK), lBkColor), 0)
        Call SendMessageAny(hToolTip, TTM_UPDATETIPTEXT, 0, tToolInfo)
        If (lStyle And TTS_BALLOON) = False Then
            Call GetClientRect(hToolTip, tClientRect)
            hdc = GetDC(hToolTip)
            hBrush = CreateSolidBrush(lTextColor)
            Call FrameRect(hdc, tClientRect, hBrush)
            Call DeleteObject(hBrush)
            Call ReleaseDC(hToolTip, hdc)
        End If
        Call SendMessageAny(hToolTip, TTM_UPDATE, 0, 0)
        Call SetProp(Application.hwnd, "ToolTip", hToolTip)
        If bBeep Then Beep
    End If

End Sub

Private Sub HideToolTip()
    Call ShowWindow(GetProp(Application.hwnd, "ToolTip"), 0)
End Sub

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Sub oForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    bTimedOut = False
End Sub


The userform code stays the same.
Click to expand...
Jaafar, thanks for this, but your modified code still doesn't compile in Excel 32-bit, it stops on Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData)).
CopyMemory is not declared for 32-bit, would it be enough just to add the 32-bit Declare in the #If Win64 Then.... #Else part ?
I tried to add it in your origial code, but then it stopped on Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
Please advise

Richard
 
Upvote 0
rplazzotta said:
Jaafar, thanks for this, but your modified code still doesn't compile in Excel 32-bit, it stops on Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData)).
CopyMemory is not declared for 32-bit, would it be enough just to add the 32-bit Declare in the #If Win64 Then.... #Else part ?
I tried to add it in your origial code, but then it stopped on Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
Please advise

Richard
Click to expand...
My bad ! I forgot to declare the CopyMemory api for 32bit

Correction made ... Try downloading the workbook again via the previous link or from the following one:
app.box.com

ControlsToolTips.xls | Powered by Box

app.box.com app.box.com
 
Upvote 0
Jaafar Tribak said:
My bad ! I forgot to declare the CopyMemory api for 32bit

Correction made ... Try downloading the workbook again via the previous link or from the following one:
app.box.com

ControlsToolTips.xls | Powered by Box

app.box.com app.box.com
Click to expand...
OK Jaafar, but in Excel 32-bit it still raises the "Unable to load common controls" error, I can't see where exactly in the cls, I think it's here but I can't be sure:

If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
If hToolTip = 0 Then
With tIccex
.Size = LenB(tIccex)
.ICC = ICC_LINK_CLASS
End With
If InitCommonControlsEx(tIccex) Then
 
Upvote 0
rplazzotta said:
OK Jaafar, but in Excel 32-bit it still raises the "Unable to load common controls" error, I can't see where exactly in the cls, I think it's here but I can't be sure:

If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
If hToolTip = 0 Then
With tIccex
.Size = LenB(tIccex)
.ICC = ICC_LINK_CLASS
End With
If InitCommonControlsEx(tIccex) Then
Click to expand...

Sorry. Again, that was my mistake. I was passing the wrong ICC to the InitCommonControlsEx api because I blindly copied it from a recent code I posted to load an hyperlink control class.

Anyway, in order to correct this mistake, simply replace the CreateToolTip routine with the following one:
VBA Code: 
Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_WIN95_CLASSES = &HFF
    Const ICC_TAB_CLASSES = &H8

    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_TAB_CLASSES
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
  
End Sub

As you can see, I have simply replaced the Const ICC_LINK_CLASS = &H8000& with Const ICC_TAB_CLASSES = &H8 witch is the correct constant needed for registering the tab and tooltip control window classes.

If that still doesn't work, try replacing the ICC_TAB_CLASSES constant with the more generic one : Const ICC_WIN95_CLASSES = &HFF

I have already updated the example workbook in the previous links with this new correction.
 
Last edited:
Upvote 0
Solution
Jaafar Tribak said:
Sorry. Again, that was my mistake. I was passing the wrong ICC to the InitCommonControlsEx api because I blindly copied it from a recent code I posted to load an hyperlink control class.

Anyway, in order to correct this mistake, simply replace the CreateToolTip routine with the following one:
VBA Code: 
Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_WIN95_CLASSES = &HFF
    Const ICC_TAB_CLASSES = &H8

    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_TAB_CLASSES
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
 
End Sub

As you can see, I have simply replaced the Const ICC_LINK_CLASS = &H8000& with Const ICC_TAB_CLASSES = &H8 witch is the correct constant needed for registering the tab and tooltip control window classes.

If that still doesn't work, try replacing the ICC_TAB_CLASSES constant with the more generic one : Const ICC_WIN95_CLASSES = &HFF

I have already updated the example workbook in the previous links with this new correction.
Click to expand...
Thank you! It now works perfectly in all my 3 environments (W7 Excel 32-bit, W10 Excel 32-bit and W10 Excel 64-bit).
 
Upvote 0
Jaafar Tribak said:
Sorry. Again, that was my mistake. I was passing the wrong ICC to the InitCommonControlsEx api because I blindly copied it from a recent code I posted to load an hyperlink control class.

Anyway, in order to correct this mistake, simply replace the CreateToolTip routine with the following one:
VBA Code: 
Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_WIN95_CLASSES = &HFF
    Const ICC_TAB_CLASSES = &H8

    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_TAB_CLASSES
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
 
End Sub

As you can see, I have simply replaced the Const ICC_LINK_CLASS = &H8000& with Const ICC_TAB_CLASSES = &H8 witch is the correct constant needed for registering the tab and tooltip control window classes.

If that still doesn't work, try replacing the ICC_TAB_CLASSES constant with the more generic one : Const ICC_WIN95_CLASSES = &HFF

I have already updated the example workbook in the previous links with this new correction.
Click to expand...
Jaafar, just a quick question. All the tooltips created with your class are positioned at the bottom right-hand corner of the controls.
Could they be positioned either at the top left-hand corner or middle left or center of the control's rectangle?
See screenshot below (btw, I've downloaded xl2bb from this site, but can't figure out how to upload an animation like yours of Oct 28).
Untitled1.jpg
 
Upvote 0
@rplazzotta

The reason I preferred to omit the tooltip position is because it sometimes gets in the way and obscures the control.

Anyway, I have amended the class code so it now offers the user to choose the tooltip position as requested. ( BottomRight being the Default position )

Workbook Demo

Here is this new Enum for setting the Tooltip position: The last enum entry (MousePos) causes the tooltip to show up at the current mouse pointer position.
VBA Code: 
Private Enum eTIP_POS
    BottomRight = 0
    BottomLeft = 1
    TopRight = 2
    TopLeft = 4
    MousePos = 8
End Enum

Set the position when calling the userform as follows:
VBA Code: 
With uTTData
   .cbSize = LenB(uTTData)
   'other UDT entries here ...
   .Position = MousePos   '<== or BottomRight , TopLeft  etc...
End With


And the here is the entire new class code for the record :
VBA Code: 
Option Explicit

Private Enum eTIP_POS
    BottomRight = 0
    BottomLeft = 1
    TopRight = 2
    TopLeft = 4
    MousePos = 8
End Enum

Private Enum eSTYLE
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_CLOSE = &H80
End Enum

Private Enum eICON
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum

Private Type ToolTipData
    cbSize As Long
    Style As eSTYLE
    BackColor As Long
    SystemInfoBackColor As Boolean 'overrides BackColor
    TextColor As Long
    SystemInfoTextColor As Boolean 'overrides TextColor
    Title As String * 64
    Icon As eICON
    Text As String * 1024
    DelayTime As Long  'in Secs
    Multiline As Boolean
    BeepSound As Boolean
    Position As eTIP_POS
End Type

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

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hwnd      As LongLong
        uId       As LongLong
        cRect     As Rect
        hinst     As LongLong
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As Rect
        hinst     As Long
#End If
   lpszText  As String
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
        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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
        Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
        Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
        Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
        Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
        Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
        Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
        Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
        Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) 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 hForm As LongPtr, hToolTip As LongPtr
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As Rect, ByVal hBrush 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) 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 hForm As Long, hToolTip As Long
#End If

Private WithEvents oForm As MSForms.UserForm

Private tGUID As GUID
Private oCtrl As Object
Private lCookie As Long
Private bTimedOut As Boolean
Private bNoTimedOut As Boolean

Private lStyle As eSTYLE, lIcon As eICON, lPosition As eTIP_POS
Private sText As String, sTitle As String
Private lBkColor As Long, lTextColor As Long
Private bSysBkColor As Boolean, bSysTextColor As Boolean
Private lTimeOut As Long
Private bMultiline As Boolean, bBeep As Boolean




'_________________________________________Class Public Methods__________________________________________________

#If Win64 Then
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As LongLong)
#Else
    Public Sub AddTo(ByVal Ctrl As MSForms.Control, ByVal DataPtr As Long)
#End If

    Const S_OK = 0
    Dim tTTipData As ToolTipData
   
    Set oCtrl = Ctrl
    Set oForm = GetUserFormObject(Ctrl)
    Call IUnknown_GetWindow(oForm, VarPtr(hForm))
   
    With tGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
   
    If ConnectToConnectionPoint(Me, tGUID, True, Ctrl, lCookie) = S_OK Then
        Call CopyMemory(ByVal tTTipData, ByVal DataPtr, LenB(tTTipData))
        With tTTipData
            sText = Left(.Text, InStr(1, .Text, vbNullChar) - 1)
            sTitle = Left(.Title, InStr(1, .Title, vbNullChar) - 1)
            lStyle = .Style
            lIcon = .Icon
            lBkColor = .BackColor
            lTextColor = .TextColor
            bSysBkColor = .SystemInfoBackColor
            bSysTextColor = .SystemInfoTextColor
            lTimeOut = Int(.DelayTime)
            If lTimeOut <= 0 Then bNoTimedOut = True
            bMultiline = .Multiline
            bBeep = .BeepSound
            lPosition = .Position
        End With
        Call CreateToolTip
    Else
          Err.Raise Number:=vbObjectError + 513, Description:="Unable to register the mouse event listener."
    End If

End Sub

Public Sub Remove()
    Call ConnectToConnectionPoint(Nothing, tGUID, False, oCtrl, lCookie)
    Call DestroyWindow(GetProp(Application.hwnd, "ToolTip"))
    Call RemoveProp(Application.hwnd, "ToolTip")
    Set oCtrl = Nothing
    Set oForm = Nothing
End Sub

Public Sub DO_NOT_USE(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Attribute DO_NOT_USE.VB_UserMemId = -606
    Call RetrieveControlUnderMousePointer(oCtrl)
End Sub



'__________________________________________Class Private Routines__________________________________________________

Private Sub RetrieveControlUnderMousePointer(ByVal Ctrl As MSForms.Control)

    Const CHILDID_SELF = &H0&
 
    Static bDoLooping As Boolean
 
    Dim tCurPos As POINTAPI, oCurAcc As IAccessible, oPrevAcc As IAccessible
    Dim px1 As Long, py1 As Long, pw1 As Long, ph1 As Long
    Dim px2 As Long, py2 As Long, pw2 As Long, ph2 As Long
    Dim sCurAccLocation As String, sPrevAccLocation As String
    Dim t As Single
 
    t = Timer
    If bDoLooping Then Exit Sub

    Do

        If bNoTimedOut = False Then
            If Int(Timer - t) >= lTimeOut Or bTimedOut = True Then bTimedOut = True: Exit Do
        End If
 
        bDoLooping = True
        Call GetCursorPos(tCurPos)
   
        #If Win64 Then
            Dim ptr As LongLong
            Call CopyMemory(ptr, tCurPos, LenB(tCurPos))
            Call AccessibleObjectFromPoint(ptr, oCurAcc, CHILDID_SELF)
        #Else
            Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oCurAcc, CHILDID_SELF)
        #End If
       
        Call oCurAcc.accLocation(px1, py1, pw1, ph1, CHILDID_SELF)
        If Not oPrevAcc Is Nothing Then
            Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        End If
     
        sCurAccLocation = CStr(px1) & CStr(py1) & CStr(pw1) & CStr(ph1)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)
   
        If oPrevAcc Is Nothing And sCurAccLocation <> sPrevAccLocation Then
               Call UpdateToolTip(px1, py1, pw1, ph1)
        End If
     
        Set oPrevAcc = Ctrl
        Call oPrevAcc.accLocation(px2, py2, pw2, ph2, CHILDID_SELF)
        sPrevAccLocation = CStr(px2) & CStr(py2) & CStr(pw2) & CStr(ph2)

        DoEvents
    Loop Until sCurAccLocation <> sPrevAccLocation

    bDoLooping = False
 
    Call HideToolTip

End Sub
Private Function GetUserFormObject(ByVal Ctrl As MSForms.Control) As Object

    Dim oTemp As Object
 
    Set oTemp = Ctrl.Parent
    Do While TypeOf oTemp Is MSForms.Control
        Set oTemp = oTemp.Parent
        DoEvents
    Loop
    Set GetUserFormObject = oTemp
 
End Function

Private Sub CreateToolTip()

    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const CW_USEDEFAULT = &H80000000
    Const ICC_WIN95_CLASSES = &HFF
    Const ICC_TAB_CLASSES = &H8
'   Const ICC_WIN95_CLASSES = &HFF

    Dim tIccex As InitCommonControlsEx

    If FindWindow("tooltips_class32", "MyToolTip") = 0 Then
        If hToolTip = 0 Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_TAB_CLASSES
            End With
            If InitCommonControlsEx(tIccex) Then
                hToolTip = CreateWindowEx(WS_EX_NOACTIVATE, "tooltips_class32", "MyToolTip", WS_POPUP, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
            Else
                Err.Raise Number:=vbObjectError + 513, Description:="Unable to load common controls."
            End If
        End If
    End If
   
End Sub


Private Sub UpdateToolTip(ByVal pX As Long, ByVal pY As Long, ByVal pw As Long, ByVal ph As Long)

    Const WM_USER = &H400
    Const TTF_TRACK = &H20
    Const TTF_ABSOLUTE = &H80
    Const TTF_TRANSPARENT = &H100
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_UPDATETIPTEXT = (WM_USER + 12)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_UPDATE = (WM_USER + 29)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
    Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
    Const TTM_SETTOOLINFO = WM_USER + 54
    Const COLOR_INFOBK = 24
    Const COLOR_INFOTEXT = 23
    Const GWL_STYLE = (-16)
 
    #If Win64 Then
        Dim hBrush As LongLong, hdc As LongLong
    #Else
        Dim hBrush As Long, hdc As Long
    #End If
   
    Dim tToolInfo As TOOLINFO, tClientRect As Rect
    Dim X As Integer, Y As Integer, lFlags As Long
   
    hToolTip = FindWindow("tooltips_class32", "MyToolTip")
   
    lFlags = TTF_TRACK Or TTF_TRANSPARENT
    Select Case lPosition
        Case BottomRight
            X = CInt(pX + pw - 5): Y = CInt(pY + ph - 5)
        Case BottomLeft
            X = CInt(pX + 5): Y = CInt(pY + ph - 5)
        Case TopRight
            X = CInt(pX + pw - 5): Y = CInt(pY + 5)
        Case TopLeft
            X = CInt(pX + 5): Y = CInt(pY + 5)
        Case MousePos
            lFlags = (lFlags Or TTF_ABSOLUTE) And Not (TTF_TRACK)
    End Select
   
    If hToolTip Then
            With tToolInfo
            .cbSize = LenB(tToolInfo)
            .hwnd = hForm
            .uId = hForm
            .uFlags = lFlags
            .lpszText = sText
        End With

        Call SetWindowLong(hToolTip, GWL_STYLE, lStyle)
        Call SendMessageAny(hToolTip, TTM_SETTITLEA, lIcon, ByVal sTitle)
        Call SendMessageAny(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        Call SendMessage(hToolTip, TTM_SETMAXTIPWIDTH, 0&, ByVal IIf(bMultiline, 1, -1))
        Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, IIf(bSysTextColor, GetSysColor(COLOR_INFOTEXT), lTextColor), 0)
        Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, IIf(bSysBkColor, GetSysColor(COLOR_INFOBK), lBkColor), 0)
        Call SendMessageAny(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(X, Y))
        Call SendMessageAny(hToolTip, TTM_SETTOOLINFO, 0, tToolInfo)
        Call SendMessageAny(hToolTip, TTM_UPDATETIPTEXT, 0, tToolInfo)

        If (lStyle And TTS_BALLOON) = False Then
            Call GetClientRect(hToolTip, tClientRect)
            hdc = GetDC(hToolTip)
            hBrush = CreateSolidBrush(lTextColor)
            Call FrameRect(hdc, tClientRect, hBrush)
            Call DeleteObject(hBrush)
            Call ReleaseDC(hToolTip, hdc)
        End If
        Call SendMessageAny(hToolTip, TTM_UPDATE, 0, 0)
        Call SetProp(Application.hwnd, "ToolTip", hToolTip)
        If bBeep Then Beep
    End If

End Sub

Private Sub HideToolTip()
    Call ShowWindow(GetProp(Application.hwnd, "ToolTip"), 0)
End Sub

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Sub oForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    bTimedOut = False
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
"Compile Error: Out of memory" with complex userform and many vba subroutines
Replies
1
Views
498
toole123
T
J
  • Question Question
Forced to discard digital signature after opening and immediately saving an Macro-Enabled Excel file
Replies
0
Views
583
JDCreate
J
R
  • Solved
Resizing Userforms in 64-bit excel
Replies
5
Views
3K
mwoollen
M
Artik
  • Solved
Show UserForm near active cell - 64-bit version
Replies
6
Views
1K
Artik
Artik
L
  • Question Question
VBA: Dynamical Userform from Module
Replies
0
Views
912
lilcrisis
L

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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