Cool Balloon Tooltips for Worksheet Tabs

Jaafar Tribak · Jun 10, 2020

Hi all,

I have just completed this code which as the thread title says, it adds a balloon tip to the worksheets of your choice... Having a tooltip displaying info about the sheet when placing the mouse pointer over the tab can be useful and fun.

The code is based on the sheet CodeName so that it keeps identifying the correct sheet even if the user changes the sheet name.

I have written the code in excel 2016-64bit but hopefully, it should work fine in other excel versions.

Although the code makes API calls, it should be stable and (hopefully) won't crash excel even if an unhandled error occurs while running.

Workbook Download

1- Class Code ( Class name is : clsTabTips)

VBA Code:

Option Explicit

Private WithEvents wb As Workbook
Private WithEvents cmb As CommandBars
Private WithEvents cmbTimeOut As CommandBars

Private Enum ICON_TYPE
    I_NoIcon
    I_Info
    I_Warning
    I_Error
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

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If VBA7 Then
        hwnd      As LongPtr
        uId       As LongPtr
        cRect     As RECT
        hinst     As LongPtr
   #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 ToolTip
    SheetCodeName As String * 256
    Title As String * 256
    Text As String * 256
    Icon As ICON_TYPE
    SystemLook As Boolean
    BackColor As XlRgbColor
    TextColor As XlRgbColor
    Beep As Boolean
    TimeOut As Single
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    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 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) 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
#End If


Private tToolTipsArray() As ToolTip, sSheetCodeNamesArray() As String
Private sngTipStartTime As Single, sngTipTimeOut As Single


Private Sub Class_Initialize()
    Set wb = ThisWorkbook
End Sub

Private Sub Class_Terminate()
    Call RemoveToolTip(True)
End Sub


Public Sub Add(ByVal TipsCollection)

    #If VBA7# Then
        Dim lPtr As LongPtr
    #Else
        Dim lPtr As Long
    #End If

    Dim tTemp() As ToolTip, lNullCharPos As Long, i As Integer

    ReDim tTemp(TipsCollection.Count)
    ReDim sSheetCodeNamesArray(TipsCollection.Count)

    For i = 1 To TipsCollection.Count
        lPtr = TipsCollection(i)
        Call CopyMemory(ByVal VarPtr(tTemp(i - 1)), ByVal lPtr, LenB(tTemp(i - 1)))
        lNullCharPos = InStr(1, tTemp(i - 1).SheetCodeName, vbNullChar, vbTextCompare)
        sSheetCodeNamesArray(i - 1) = Left(tTemp(i - 1).SheetCodeName, lNullCharPos)
    Next i

    tToolTipsArray = tTemp

    Set cmb = Application.CommandBars
    Call cmb_OnUpdate

End Sub


Private Sub cmb_OnUpdate()

    Const ROLE_SYSTEM_HELPBALLOON = &H1F
    Const ROLE_SYSTEM_PAGETAB = &H25
    Const CHILDID_SELF = &H0&
    Const S_OK = &H0

    Static oPrveAcc As IAccessible

    Dim vChild As Variant, oIAcc As IAccessible, oIAParent As IAccessible
    Dim tCurPos As POINTAPI, sTextUnderMouse As String, indx As Long


    On Error Resume Next

    If Not ActiveWorkbook Is ThisWorkbook Then GoTo Xit

    Call GetCursorPos(tCurPos)

    #If Win64 Then
        Dim lPt As LongPtr
        Call CopyMemory(lPt, tCurPos, LenB(lPt))
        If AccessibleObjectFromPoint(lPt, oIAcc, vChild) = S_OK Then
    #Else
        If AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oIAcc, vChild) = S_OK Then
    #End If

            If oIAcc.accRole(CHILDID_SELF) = ROLE_SYSTEM_PAGETAB Then
                If oPrveAcc.accName(CHILDID_SELF) <> oIAcc.accName(CHILDID_SELF) Then
            
                    Set oIAParent = oIAcc.accParent
                    If oIAParent.accName(CHILDID_SELF) = "Sheet Tabs" Then
                        sTextUnderMouse = oIAcc.accName(0&)
                        sTextUnderMouse = GetSheetCodeName(sTextUnderMouse)
                        indx = Application.Match(sTextUnderMouse, sSheetCodeNamesArray, 0)
                        If indx Then
                            Call CreateToolTip(tToolTipsArray(indx - 1))
                        Else
                            Call RemoveToolTip
                        End If
                    End If
                End If
            Else
                Call RemoveToolTip
            End If
        End If

Xit:

    Set oPrveAcc = oIAcc

    If GetActiveWindow <> Application.hwnd Or _
        oIAcc.accRole(CHILDID_SELF) = ROLE_SYSTEM_HELPBALLOON Then
            Call RemoveToolTip
    End If

    Application.CommandBars.FindControl(ID:=2040).Enabled = _
    Not Application.CommandBars.FindControl(ID:=2040).Enabled

End Sub




Private Sub CreateToolTip(ToolTipStruct As ToolTip)

    Const CW_USEDEFAULT = &H80000000
    Const WS_POPUP = &H80000000
    Const WM_USER = &H400
    Const TTS_BALLOON = &H40
    Const TTS_NOPREFIX = &H2
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
    Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
    Const TTF_TRACK = &H20
    Const ICC_WIN95_CLASSES = &HFF

    #If VBA7 Then
        Dim hToolTip As LongPtr
    #Else
            Dim hToolTip As Long
    #End If

    Dim tToolInfo As TOOLINFO, tCurPos As POINTAPI, tIccex As InitCommonControlsEx, lIcon As ICON_TYPE
    Dim sTitle As String, sText As String
    Dim lBackColor As Long, lForeColor As Long
    Dim bSysLook As Boolean, bBeep As Boolean
    Dim sngTimeOut As Single, lNullCharPos As Long

    With ToolTipStruct
        lNullCharPos = InStr(1, .Title, vbNullChar, vbTextCompare)
        sTitle = Left(.Title, lNullCharPos)
        lNullCharPos = InStr(1, .Text, vbNullChar, vbTextCompare)
        sText = Left(.Text, lNullCharPos)
        lIcon = .Icon
        bSysLook = .SystemLook
        lBackColor = .BackColor
        lForeColor = .TextColor
        bBeep = .Beep
        sngTimeOut = .TimeOut
    End With

    Call RemoveToolTip

    Call GetCursorPos(tCurPos)
            
    If IsWindow(hToolTip) = 0 Then

        With tIccex
            .Size = LenB(tIccex)
            .ICC = ICC_WIN95_CLASSES
        End With
    
        Call InitCommonControlsEx(tIccex)
    
        hToolTip = CreateWindowEx(0, "tooltips_class32", "MyToolTip", WS_POPUP Or TTS_BALLOON Or TTS_NOPREFIX, _
        CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
    
        If hToolTip Then
    
            With tToolInfo
                .cbSize = LenB(tToolInfo)
                .uFlags = TTF_TRACK
                .lpszText = sText
            End With
        
            Call SendMessage(hToolTip, TTM_SETTITLEA, lIcon, ByVal sTitle)
            Call SendMessage(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        
            If Not bSysLook Then
                Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, lBackColor, 0)
                Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, lForeColor, 0)
            End If
        
            With tCurPos
                Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
                Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.x), CInt(.y)))
            End With
        
            If bBeep Then
                Call Beep
            End If
        
            If sngTimeOut Then
                sngTipTimeOut = sngTimeOut
                If sngTipTimeOut >= 20 Then sngTipTimeOut = 20
                If sngTipTimeOut <= 1 Then sngTipTimeOut = 1
                sngTipStartTime = Timer
                Set cmbTimeOut = Application.CommandBars
            End If
        
        End If
    
    End If


End Sub


Private Sub cmbTimeOut_OnUpdate()
    If Timer - sngTipStartTime >= sngTipTimeOut Then
           Call RemoveToolTip(True)
    End If
End Sub


Private Function GetSheetCodeName(ByVal TabName As String) As String

    Dim i As Long

    For i = 1 To ThisWorkbook.Sheets.Count
        If ThisWorkbook.Sheets(i).Name = TabName Then
            GetSheetCodeName = ThisWorkbook.Sheets(i).CodeName
            Exit Function
        End If
    Next

End Function

Private Sub RemoveToolTip(Optional ByVal StopTimeOutEvents As Boolean = False)

    If StopTimeOutEvents Then
        Set cmbTimeOut = Nothing
    End If

    If IsWindow(FindWindow("tooltips_class32", "MyToolTip")) Then
        Call DestroyWindow(FindWindow("tooltips_class32", "MyToolTip"))
    End If

End Sub

Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function

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

Private Sub wb_Deactivate()
        Call RemoveToolTip(True)
End Sub

2- Code Usage Example in a Standard Module:

VBA Code:

Option Explicit

Private Enum ICON_TYPE
    I_NoIcon
    I_Info
    I_Warning
    I_Error
End Enum

Private Type ToolTip
    SheetCodeName As String * 256
    Title As String * 256
    Text As String * 256
    Icon As ICON_TYPE
    SystemLook As Boolean
    BackColor As XlRgbColor
    TextColor As XlRgbColor
    Beep As Boolean
    TimeOut As Single
End Type

Private oTabTips As clsTabTips


Sub Test()

    Dim oTip1 As ToolTip
    Dim oTip2 As ToolTip
    Dim oTip3 As ToolTip
    Dim oTip4 As ToolTip
    Dim oTip5 As ToolTip

    Dim oCol As Collection


    With oTip1
        .SheetCodeName = Sheet1.CodeName & vbNullChar
        .Title = Sheet1.Name & vbNullChar
        .Text = "This is a Balloon Tooltip with no custom formatting." & vbNewLine & _
        "The Tooltip has a timer set and will vanish in 10 Secs." & vbNullChar
        .Icon = I_Info
        .SystemLook = True
        .Beep = True
        .TimeOut = 10
    End With

    With oTip2
        .SheetCodeName = Sheet2.CodeName & vbNullChar
        .Title = Sheet2.Name & vbNullChar
        .Text = "The Balloon attributes won't change even if the tab name is changed." & vbNullChar
        .Icon = I_Warning
        .BackColor = rgbAliceBlue
        .TextColor = rgbDarkSlateGray
    End With

    With oTip3
        Dim sText As String, i As Long
        sText = "Max Charcters 256." & vbNewLine & vbNewLine
        sText = sText & "Testing a long text entry."
        For i = 1 To 7
            sText = sText & vbNewLine & "Testing a long text entry."
        Next i
        .SheetCodeName = Sheet3.CodeName & vbNullChar
        .Title = Sheet3.Name & vbNullChar
        .Text = sText & vbNullChar
        .Icon = I_NoIcon
        .BackColor = rgbGreenYellow
        .TextColor = rgbDarkSlateGray
    End With

    With oTip4
        .SheetCodeName = Sheet4.CodeName & vbNullChar
        .Title = Sheet4.Name & vbNullChar
        .Text = "This is a Balloon Tooltip with no custom formatting." & vbNewLine & _
        "The Tooltip has a timer set and will vanish in 10 Secs." & vbNullChar
        .Icon = I_Info
        .BackColor = rgbLightGray
        .TextColor = rgbDarkRed
        .Beep = True
    End With

    With oTip5
        .SheetCodeName = Sheet5.CodeName & vbNullChar
        .Title = Sheet5.Name & vbNullChar
        .Text = "Just another TabTip !" & vbNullChar
        .Icon = I_Info
        .BackColor = rgbMistyRose
    End With


    Set oCol = New Collection

    oCol.Add VarPtr(oTip1)
    oCol.Add VarPtr(oTip2)
    oCol.Add VarPtr(oTip3)
    oCol.Add VarPtr(oTip4)
    oCol.Add VarPtr(oTip5)

    Set oTabTips = New clsTabTips

    oTabTips.Add oCol

End Sub


Sub StopTest()

    Set oTabTips = Nothing

End Sub

Jaafar Tribak · Sep 20, 2022

Hi,

Here is a nice update . It uses a sightly different approach by setting the tooltip parent to the EXCEL7 window. I hope this will make the tooltip more reliable.

Note that this new tooltip class is unicode compliant so it can now display tips in non ascii foreign characters. ... It also allows choosing a custom font which the user can flexibly set the fontname, size and weight.

Another cool thing I have added to this update is the sound wav that can be optionally played. The wav file bytes are automatically extracted from the wav oleobject that is embedded in the worksheet. This takes place once upon first creating the class instance.

If you want, you can change the embedded oleobject wav to play different sounds.

TabTipsUnicode.xlsm

1- clsTabTips Class :

VBA Code:

Option Explicit

'Unicode Tooltips for worksheet tabs.
'Formatted + wav sound.
'Written on 20/September/2022 & MrExcel.com.

' Class Method 1.
' ==============
    'Public Sub AddToolTip( _
    '    ByVal Sh As Worksheet, _
    '    ByVal TipText As String, _
    '    Optional ByVal Icon As ICON_TYPE, _
    '    Optional ByVal Title As String, _
    '    Optional ByVal ForeColor As Long = -1, _
    '    Optional ByVal BackColor As Long = -1, _
    '    Optional ByVal Balloon As Boolean, _
    '    Optional ByVal FontName As String = "Segoe UI", _
    '    Optional ByVal FontSize As Long = 12, _
    '    Optional ByVal FontBold As Boolean, _
    '    Optional ByVal PlaySound As Boolean, _
    '    Optional ByVal RightToLeftReadingOrder As Boolean, _
    '    Optional ByVal VisibleTime As Long = 5000 _
    ')

' Class Method 2.
' ==============
    'Public Sub Activate()


Private WithEvents wb As Workbook
Private WithEvents cmb As CommandBars
Private WithEvents cmb2 As CommandBars

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 LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName  As String * 32
End Type

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

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
    #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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageLong Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPtr
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem 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 sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function waveOutGetNumDevs Lib "winmm.dll" () As Long
    
    Private hFont 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem 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 sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
    
    Private hFont As Long, hToolTip As Long
#End If

Private bWavBytesBuffer() As Byte

Private sSheetCodeNamesArray() As String
Private arText() As String
Private arIcon() As Long
Private arTitle() As String
Private arForeColor() As Long
Private arBackColor() As Long
Private arBalloon() As Boolean
Private arFontName() As String
Private arFontSize() As Long
Private arFontBold() As Boolean
Private arPlaySound() As Boolean
Private arRightToLeftReadingOrder() As Boolean
Private arVisibleTime() As Long
 
    
' change if required.
Private Const EMBEDDED_WAV_OBJECT = "ToolTipSound"
Private Const WAV_OBJECT_PARENT_SHEET = "Sheet1"



'__________________________________________ Class Init\Term Events ________________________________________________
Private Sub Class_Initialize()
    Set wb = ThisWorkbook
End Sub

Private Sub Class_Terminate()
    Call RemoveToolTip
    Set cmb = Nothing
'    Debug.Print "class terminated."
End Sub



'__________________________________________ Public Class Methods _________________________________________________________
Public Sub AddToolTip( _
    ByVal Sh As Worksheet, _
    ByVal TipText As String, _
    Optional ByVal Icon As ICON_TYPE, _
    Optional ByVal Title As String, _
    Optional ByVal ForeColor As Long = -1, _
    Optional ByVal BackColor As Long = -1, _
    Optional ByVal Balloon As Boolean, _
    Optional ByVal FontName As String = "Segoe UI", _
    Optional ByVal FontSize As Long = 12, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal PlaySound As Boolean, _
    Optional ByVal RightToLeftReadingOrder As Boolean, _
    Optional ByVal VisibleTime As Long = 5000 _
)

    If (Not sSheetCodeNamesArray) = -1 Then
        ReDim sSheetCodeNamesArray(0)
        ReDim arText(0)
        ReDim arIcon(0)
        ReDim arTitle(0)
        ReDim arForeColor(0)
        ReDim arBackColor(0)
        ReDim arBalloon(0)
        ReDim arFontName(0) As String
        ReDim arFontSize(0) As Long
        ReDim arFontBold(0) As Boolean
        ReDim arPlaySound(0) As Boolean
        ReDim arRightToLeftReadingOrder(0) As Boolean
        ReDim arVisibleTime(0)
    Else
        ReDim Preserve sSheetCodeNamesArray(UBound(sSheetCodeNamesArray) + 1)
        ReDim Preserve arText(UBound(arText) + 1)
        ReDim Preserve arIcon(UBound(arIcon) + 1)
        ReDim Preserve arTitle(UBound(arTitle) + 1)
        ReDim Preserve arForeColor(UBound(arForeColor) + 1)
        ReDim Preserve arBackColor(UBound(arBackColor) + 1)
        ReDim Preserve arBalloon(UBound(arBalloon) + 1)
        ReDim Preserve arFontName(UBound(arFontName) + 1)
        ReDim Preserve arFontSize(UBound(arFontSize) + 1)
        ReDim Preserve arFontBold(UBound(arFontBold) + 1)
        ReDim Preserve arPlaySound(UBound(arPlaySound) + 1)
        ReDim Preserve arRightToLeftReadingOrder(UBound(arRightToLeftReadingOrder) + 1)
        ReDim Preserve arVisibleTime(UBound(arVisibleTime) + 1)
    End If
    
    sSheetCodeNamesArray(UBound(sSheetCodeNamesArray)) = Sh.Name
    arText(UBound(arText)) = TipText
    arIcon(UBound(arIcon)) = Icon
    arTitle(UBound(arTitle)) = Title
    arForeColor(UBound(arForeColor)) = ForeColor
    arBackColor(UBound(arBackColor)) = BackColor
    arBalloon(UBound(arBalloon)) = Balloon
    arFontName(UBound(arFontName)) = FontName
    arFontSize(UBound(arFontSize)) = FontSize
    arFontBold(UBound(arFontBold)) = FontBold
    arPlaySound(UBound(arPlaySound)) = PlaySound
    arRightToLeftReadingOrder(UBound(arRightToLeftReadingOrder)) = RightToLeftReadingOrder
    arVisibleTime(UBound(arVisibleTime)) = VisibleTime

End Sub

Public Sub Activate()
    If (Not sSheetCodeNamesArray) = -1 Then
        MsgBox "No tooltips have been added yet.", vbCritical
        Exit Sub
    End If
    
    If SoundOleObjectExists Then
        Call BuildSoundArray(Worksheets(WAV_OBJECT_PARENT_SHEET).OLEObjects(EMBEDDED_WAV_OBJECT))
    Else
        MsgBox "wav object missing"
    End If
    
    Set cmb = Application.CommandBars
End Sub



'_______________________________________ Private Class Routines _________________________________________________
Private Sub cmb_OnUpdate()

    Const ROLE_SYSTEM_HELPBALLOON = &H1F
    Const ROLE_SYSTEM_PAGETAB = &H25
    Const ROLE_SYSTEM_PAGETABLIST = &H3C&
    Const CHILDID_SELF = &H0&
    Const S_OK = &H0
    
    Static oPrveAcc As IAccessible
    
    Dim vChild As Variant, oIAcc As IAccessible, oIAParent As IAccessible
    Dim tCurPos As POINTAPI, sTextUnderMouse As String, indx As Long

    
    On Error Resume Next
    
    If Not ActiveWorkbook Is ThisWorkbook Then Call RemoveToolTip: GoTo Xit
    If GetActiveWindow <> Application.hwnd Then Call RemoveToolTip: GoTo Xit
    
    Call GetCursorPos(tCurPos)
    
    #If Win64 Then
        Dim lPt As LongLong
        Call CopyMemory(lPt, tCurPos, LenB(lPt))
        If AccessibleObjectFromPoint(lPt, oIAcc, vChild) = S_OK Then
    #Else
        If AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oIAcc, vChild) = S_OK Then
    #End If
            If oIAcc.accRole(CHILDID_SELF) = ROLE_SYSTEM_PAGETAB Then
                If oPrveAcc.accName(CHILDID_SELF) <> oIAcc.accName(CHILDID_SELF) Then
                Set oIAParent = oIAcc.accParent
                    If oIAParent.accRole(CHILDID_SELF) = ROLE_SYSTEM_PAGETABLIST Then
                        sTextUnderMouse = oIAcc.accName(0&)
                        If Not IsError(Application.Match(sTextUnderMouse, sSheetCodeNamesArray, 0)) Then
                            indx = Application.Match(sTextUnderMouse, sSheetCodeNamesArray, 0)
                            If indx Then
                                indx = indx - 1
                                Call CreateToolTip(arText(indx), arIcon(indx), arTitle(indx), _
                                arForeColor(indx), arBackColor(indx), arBalloon(indx), arFontName(indx), _
                                arFontSize(indx), arFontBold(indx), arPlaySound(indx), _
                                arRightToLeftReadingOrder(indx), arVisibleTime(indx))
                            End If
                        Else
                            Call RemoveToolTip
                        End If
                    End If
                End If
            Else
                Call RemoveToolTip
            End If
        End If

Xit:
    Set oPrveAcc = oIAcc
    Application.CommandBars.FindControl(ID:=2040).Enabled = _
            Not Application.CommandBars.FindControl(ID:=2040).Enabled
    
    PreventSleepMode = True

End Sub

Private Sub cmb2_OnUpdate()
    If IsWindowVisible(hToolTip) Then
        Call PlaySoundNow
        Set cmb2 = Nothing
    End If
End Sub

Private Function SoundOleObjectExists() As Boolean
    On Error Resume Next
    SoundOleObjectExists = Not IsError(Worksheets(WAV_OBJECT_PARENT_SHEET).OLEObjects(EMBEDDED_WAV_OBJECT))
End Function

Private Sub RemoveToolTip()
    If IsWindow(FindWindow("tooltips_class32", "MyToolTip")) Then
        Call DeleteObject(hFont)
        Call DestroyWindow(FindWindow("tooltips_class32", "MyToolTip"))
'        Debug.Print "Tooltip Destroyed."
    End If
End Sub

Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED As Long = &H1
    Const ES_DISPLAY_REQUIRED As Long = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS As Long = &H80000000
  
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

Private Sub CreateToolTip( _
        ByVal TipText As String, _
        ByVal Icon As Long, _
        ByVal Title As String, _
        ByVal ForeColor As Long, _
        ByVal BackColor As Long, _
        ByVal Balloon As Boolean, _
        ByVal FontName As String, _
        ByVal FontSize As Long, _
        ByVal FontBold As Boolean, _
        ByVal PlaySound As Boolean, _
        ByVal RightToLeftReadingOrder As Boolean, _
        ByVal VisibleTime As Long _
    )
                          
        Const TOOLTIPS_CLASSA = "tooltips_class32"
        Const ICC_WIN95_CLASSES = &HFF
        Const CW_USEDEFAULT = &H80000000
        Const WS_EX_NOACTIVATE = &H8000000
        Const WS_EX_LAYOUTRTL = &H400000
        Const WM_USER = &H400
        Const TTM_ADDTOOLW = WM_USER + 4
        Const TTM_SETDELAYTIME = WM_USER + 3
        Const TTM_UPDATETIPTEXTW = WM_USER + 57
        Const TTM_SETTIPBKCOLOR = WM_USER + 19
        Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
        Const TTM_SETTITLE = WM_USER + 32
        Const TTM_TRACKACTIVATE = (WM_USER + 17)
        Const TTM_TRACKPOSITION = (WM_USER + 18)
        Const TTS_NOPREFIX = &H2
        Const TTS_BALLOON = &H40
        Const TTS_ALWAYSTIP = &H1
        Const TTF_IDISHWND = &H1
        Const TTF_SUBCLASS = &H10
        Const TTF_TRACK = &H20
        Const TTF_CENTERTIP = &H2
        Const TTDT_AUTOPOP = 2
        Const WM_SETFONT = &H30
        Const WM_GETFONT = &H31
      
        #If Win64 Then
            Dim hParent As LongLong
        #Else
            Dim hParent As Long
        #End If
      
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long, lWinExStyle As Long, lRealColor As Long
        Dim uTTInfo As TOOLINFOW, tIccex As InitCommonControlsEx, tFont As LOGFONT, tCurPos As POINTAPI
      
 
        If Not bCommonControlsInitialized Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_WIN95_CLASSES
            End With
            If InitCommonControlsEx(tIccex) = False Then
                Call InitCommonControls
            End If
            bCommonControlsInitialized = True
        End If
    
        Call RemoveToolTip
        
        lWinExStyle = WS_EX_NOACTIVATE + IIf(RightToLeftReadingOrder, WS_EX_LAYOUTRTL, 0&)
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If Balloon Then lWinStyle = lWinStyle Or TTS_BALLOON
        hToolTip = CreateWindowEx(lWinExStyle, ByVal StrPtr(TOOLTIPS_CLASSA), ByVal StrPtr("MyToolTip"), _
                    lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                    0&, 0&, GetModuleHandle(vbNullString), 0&)
                        
        hFont = SendMessage(hToolTip, WM_GETFONT, 0, 0)
        Call GetObjectAPI(hFont, LenB(tFont), tFont)
        With tFont
            .lfHeight = -FontSize
            .lfWeight = IIf(FontBold, 800, .lfWeight)
            .lfFaceName = FontName & vbNullChar
        End With
        Call DeleteObject(hFont)
        hFont = CreateFontIndirect(tFont)
        Call SendMessage(hToolTip, WM_SETFONT, hFont, True)
      
        hParent = FindWindowEx(FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString) _
            , 0&, "EXCEL7", vbNullString)

        With uTTInfo
            If RightToLeftReadingOrder Then
                .uFlags = TTF_TRACK + TTF_CENTERTIP
            Else
                .uFlags = TTF_SUBCLASS Or TTF_IDISHWND
            End If
            .hwnd = hParent
            .uId = hParent
            .hinst = GetModuleHandle(vbNullString)
            .lpszText = StrPtr(TipText)
            .cbSize = LenB(uTTInfo)
        End With
      
        Call SendMessage(hToolTip, TTM_ADDTOOLW, 0&, uTTInfo)
        Call SendMessage(hToolTip, TTM_UPDATETIPTEXTW, 0&, uTTInfo)
      
        If ForeColor <> -1 Then SendMessage hToolTip, TTM_SETTIPTEXTCOLOR, ForeColor, 0&
        If BackColor <> -1 Then
            Call TranslateColor(BackColor, 0, lRealColor)
            Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, lRealColor, 0&)
        End If
      
        If Icon <> I_NoIcon Or Title <> vbNullString Then _
                Call SendMessage(hToolTip, TTM_SETTITLE, CLng(Icon), ByVal Title)
        Call SendMessageLong(hToolTip, TTM_SETDELAYTIME, TTDT_AUTOPOP, VisibleTime)
        
        If RightToLeftReadingOrder Then
            Call GetCursorPos(tCurPos)
            With tCurPos
                Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, uTTInfo)
                Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.x), CInt(.y)))
            End With
        End If
              
        If PlaySound And SoundOleObjectExists Then
            Set cmb2 = Application.CommandBars
        End If

End Sub

Private Sub PlaySoundNow()
    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Const SND_MEMORY = &H4
    If waveOutGetNumDevs > 0 Then
        sndPlaySound bWavBytesBuffer(InStr(StrConv(bWavBytesBuffer, vbUnicode), "RIFF") - 1), _
                    SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
    End If
End Sub

Private Function BuildSoundArray(WAVOleObject As OLEObject) As Boolean

    Const CF_NATIVE = &HC004&

    #If Win64 Then
        Dim hClipMem As LongLong, lMemSize As LongLong, lMemPtr As LongLong
    #Else
        Dim hClipMem As Long, lMemSize As Long, lMemPtr As Long
    #End If
    
    On Error GoTo Xit

    WAVOleObject.Copy
    DoEvents
    If OpenClipboard(0) Then
        hClipMem = GetClipboardData(CF_NATIVE)
        If hClipMem Then lMemSize = GlobalSize(hClipMem)
        If lMemSize Then lMemPtr = GlobalLock(hClipMem)
        If lMemPtr Then
            ReDim bWavBytesBuffer(0 To CLng(lMemSize) - 1) As Byte
            Call CopyMemory(bWavBytesBuffer(0), ByVal lMemPtr, lMemSize)
            If (Not bWavBytesBuffer) = -1 Then
                BuildSoundArray = True
            End If
            Call GlobalUnlock(hClipMem)
        End If
        Call EmptyClipboard
        Call CloseClipboard
    End If
    Exit Function
Xit:
    Call CloseClipboard

End Function

Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function

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

Private Sub wb_Deactivate()
    Call RemoveToolTip
End Sub

2- Code Usage Example in a Standard module:

VBA Code:

Option Explicit

Public Enum ICON_TYPE
    I_NoIcon
    I_Info
    I_Warning
    I_Error
End Enum

Private OToolTips As clsTabTips

Public Sub Start()

    Set OToolTips = New clsTabTips
    
    With OToolTips
    
        .AddToolTip Sheet1, "This is a Multiline ToolTip with Sound." & vbCr & vbCr & "Line2 ..." & _
            vbCr & "Line3 ..." & vbCr & "Line4 ..." & vbCr & "Line5 ..." & vbCr, _
            I_Info, "Title", , , True, , , , True, , 10000
        
        .AddToolTip Sheet2, "Basic Rectangular Tooltip without any formatting."
        
        .AddToolTip Sheet3, "These are 'tooltips_class32' class-based controls" _
            & vbCr & "from the COMCTL32 library.", I_Info, " ", vbWhite, 0, True
        
        .AddToolTip Sheet4, "Hey, vba coding is fun." & vbCr & _
            "But combining vba with The Win32 api is even more fun !!", I_Info, _
            "Hello MrExcel", vbRed, &HFFE1FF, True, "Old English Text MT", 30, , , , 20000
        
        .AddToolTip Sheet5, "This is a formatted Tooltip for : " & vbCr & _
            Sheet5.CodeName, I_Warning, "Tooltip With Sound.", , &HFFFFCC, True, , , , True, , 5000
        
        'Test for unicode (text located in range K3:K8)... pass lang as needed.
        .AddToolTip Sheet6, Sheet1.Range("K3").Text, I_Error, "UNICODE TEST TAKEN FORM RANGE [K3:K8]" _
            , , &H99FFCC, True, , , , , True, 15000
        
        .Activate
    
    End With

End Sub

Sub Finish()
    Set OToolTips = Nothing
End Sub

Sub Dummy()
    'dummy sub for embedded wav oleobject.
End Sub

Regards.

Dan_W · Sep 21, 2022

Thank you, Jaafar. This is very helpful.

Out of curiosity, it used to be the case that these tooltips would allow for buttons or some kind of textbox, so as to get further input from the user. Though I haven't haven't seen any tooltips implementation recently (not least for VBA) that includes this kind of UI. Do you happen to know if it's still possible to do this? Or is it one of the deprecated features?

Dan_W · Sep 21, 2022

Specifically, something like:

Jaafar Tribak · Sep 22, 2022

Dan_W said:
Specifically, something like:
View attachment 74460

Do you happen to know if it's still possible to do this? Or is it one of the deprecated features?

That tooltip UI image reminds me of themes used in older editions of Windows... I have done a quick search in the commctrl header file for the tooltips_class32 class but I don't see any defined styles that would suggest such UI. So, I don't know if is possible to do this.

That said, since the tooltip is a window, I guess, we could , in theroy, make it a parent of child controls (combo, image, hyperlink text etc ) but that would require some complicated coding. Furthermore, it would require subclassing the child controls or the parent tooltip in order to be interactive which is not recommended in this case.

Such tooltip is probably better suited for the Windows system tray in the taskbar.

Dan_W · Sep 22, 2022

I suspect that these UI elements would have been found back in the days of everyones favourite Office Assistant, Clippy! So that would be Win95...? I will have a proper look, but thought you might know off the top of your head, so should check with you.

The workaround seems to involve a whole lot of effort for questionable reward. Thank you kindly for looking into this for me. It was really random thought than an earnest desire.

Tobi Shi · Mar 1, 2023

Hi Jaafar,

great work. Thank you for sharing.

A few issues I encountered (in the Unicode version)

- Setting RightToLeftReadingOrder:=True causes the balloon appear below the mouse cursor. If there is not enough screen space, the balloon appears at the top near formula bar.
- Also, the balloon has round corners if RightToLeftReadingOrder:=True. Would it be possible to force round corners even with Left-To-Right order?

- Sometimes, when hovering above a tab (while tooltip showing), pressing ESC causes run-time error. Upon clicking Debug, VBA jumps to 'cmb_OnUpdate'. Do you think it would be possible to prevent that? (I have tried with EnableCancelKey = False, but it did not help)

Jaafar Tribak · Mar 5, 2023

@Tobi Shi

Hi Tobi, sorry for not responding to you sooner.

When I set RightToLeftReadingOrder:=True it causes the balloon to appear below the mouse cursor only if there is screen space below. The tooltips_class32 is clever enough to automatically re-position itself when spilling out of the screen if the correct tootip styles and flags are applied to it... I am not sure why it appears for you near the formula bar !!! .... Are you adapting the code to work for other than the sheet tabs such as for displaying the tooltip when mouse-pointing to a cell, a shape or a userform?

As you can see from the above GIF clip, the unicode tooltip corners are round except a slight defect on the left border.

Regarding the problem with the ESC key , I couldn't reproduce the issue you described.

I will need to revisit the code anyway as I have now realised that I stupidly forgot to enable unicode for the tooltip title and in the process, I will see if I can improve the screen location\look of the unicode tooltip ( ie:= RightToLeft for Arabic and Hebrew)

Tobi Shi · Mar 7, 2023

Jaafar Tribak said:
@Tobi Shi

Hi Tobi, sorry for not responding to you sooner.

When I set RightToLeftReadingOrder:=True it causes the balloon to appear below the mouse cursor only if there is screen space below. The tooltips_class32 is clever enough to automatically re-position itself when spilling out of the screen if the correct tootip styles and flags are applied to it... I am not sure why it appears for you near the formula bar !!! .... Are you adapting the code to work for other than the sheet tabs such as for displaying the tooltip when mouse-pointing to a cell, a shape or a userform?

As you can see from the above GIF clip, the unicode tooltip corners are round except a slight defect on the left border.

Regarding the problem with the ESC key , I couldn't reproduce the issue you described.

I will need to revisit the code anyway as I have now realised that I stupidly forgot to enable unicode for the tooltip title and in the process, I will see if I can improve the screen location\look of the unicode tooltip ( ie:= RightToLeft for Arabic and Hebrew)

Using your original file (no changes), I do not get the round balloon, neither the colors. Also, the long text is cut out (but combining vba ...) See screenshots below

I guess the unicode version also needs the call SetWindowTheme(hToolTip, " ", " ")"

Regarding ESC key: It is kind of erratic. You have to press ESC multiple times (10 +) to reproduce it. But if "un/lucky" you can catch it with the first key-down (this is what happened to me and which is confusing for users if ToolTips would be implemented in a client-side tool)

I hope that helps

Jaafar Tribak · Mar 7, 2023

@Tobi Shi

Thanks.. I think I see what is going on. ComCtl32.dll version 6 should be used in order to enable visual styles. This would probably correct the issue with RightToLeft tooltips. However, this will require a XML minifest. Hopefully, I should be able to apply the manifest at runtime.

I will give this a try and see what comes up.

Dan_W · Mar 8, 2023

Jaafar Tribak said:
@Tobi Shi

Thanks.. I think I see what is going on. ComCtl32.dll version 6 should be used in order to enable visual styles. This would probably correct the issue with RightToLeft tooltips. However, this will require a XML minifest. Hopefully, I should be able to apply the manifest at runtime.

I will give this a try and see what comes up.

On the topic of manifests, if I may ask, what are they and how do we use them? I see them referenced in VB6,, but it's not clear to me how this applies to VBA.

Cool Balloon Tooltips for Worksheet Tabs

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Excel Facts

Dan_W

Well-known Member

Dan_W

Well-known Member

Jaafar Tribak

Well-known Member

Dan_W

Well-known Member

Tobi Shi

New Member

Jaafar Tribak

Well-known Member

Tobi Shi

New Member

Jaafar Tribak

Well-known Member

Dan_W

Well-known Member

Similar threads

Forum statistics

Share this page

Cool Balloon Tooltips for Worksheet Tabs

Well-known Member

Well-known Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock