Cool Balloon Tooltips for Worksheet Tabs

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,797
Office Version
  1. 2016
Platform
  1. Windows
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



TabTips.gif






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
 
Sort by date Sort by votes
Tom.Jones said:
@JAAFAR,

Indeed, there was no English editions of excel on the laptop I tested, but I made the proposed change and now the code works perfectly.

I also tested the code on an English editions of excel version, and without any code changes, it worked perfectly.

You are amazing.
Thanks.
Click to expand...

Great !
Glad it eventually workes for you and thanks for the feedback.
 
Upvote 0

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sorry for resurrecting this thread, but I noticed the other day that the tooltips in my copy of this workbook weren't displaying in the custom colours/formatting like they used to. Instead, now, the it uses the 'classic' straightforward format. To make sure I hadn't stuffed up something with the code, I downloaded another copy from the link above, and it doesn't have the formatting applied either. It's not problematic for me, but I just thought I'd point it out and ask whether anyone knew of a reason this was happening (assuming it was happening to other people as well....?)

Pictures of the current style below:
1660468112930.png
1660468133915.png
1660468158102.png
 
Upvote 0
Thanks Dan for bringing this up.

I hvae done some research and found that according to the MSDN : "When visual styles are enabled, this message has no effect."

Not sure if that is the reason why colors don't take effect but I would try the following and see if it solves the problem :

* Add these Declares to the clsTabTips class module :
VBA Code: 
#If VBA7 Then
    Private Declare PtrSafe Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As LongPtr, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As Long
#Else
    Private Declare Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As Long
#End If

* and then, to disable the visual styles for the tooltip, edit the code in the CreateToolTip SUB as follows:
VBA Code: 
If Not bSysLook Then
    Call SetWindowTheme(hToolTip, vbNullString, vbNullString)
    Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, lBackColor, 0)
    Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, lForeColor, 0)
End If

Regards.
 
Upvote 0
Good Morning

Thanks very much for this - It will help me with some of my spreadsheets with process information

Is it possible to have changes made to the code that will allow the TAB information to be managed without going into the code

example: Have an "Tab info" sheet where for example
in Cell A1:D5 I can type the info for sheet 1
in Cell A7:D12 I can type the info for sheet 2
etc
The "Tab info" sheet can then be hidden

This will help to easily make changes to the "Baloons" without accessing the VBA code

Thanks

Joe
 
Upvote 0
Jaafar Tribak said:
Thanks Dan for bringing this up.

I hvae done some research and found that according to the MSDN : "When visual styles are enabled, this message has no effect."

Not sure if that is the reason why colors don't take effect but I would try the following and see if it solves the problem :

* Add these Declares to the clsTabTips class module :
VBA Code: 
#If VBA7 Then
    Private Declare PtrSafe Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As LongPtr, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As Long
#Else
    Private Declare Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As Long
#End If

* and then, to disable the visual styles for the tooltip, edit the code in the CreateToolTip SUB as follows:
VBA Code: 
If Not bSysLook Then
    Call SetWindowTheme(hToolTip, vbNullString, vbNullString)
    Call SendMessage(hToolTip, TTM_SETTIPBKCOLOR, lBackColor, 0)
    Call SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, lForeColor, 0)
End If

Regards.
Click to expand...

Hi Jaafar

I tried doing this on my system however I still do not see the custom formatting, see just the default one... Also when I update as per above the Start TabTips button disappears? Below is how I updated... maybe I did it wrong? Using Office 365 on Windows 10 Pro...

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
    Private Declare PtrSafe Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As LongPtr, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As Long
#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
    Private Declare Function SetWindowTheme Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszSubAppName As String, ByVal pszSubIdList As String) 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 SetWindowTheme(hToolTip, vbNullString, vbNullString)
                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

Untitled.png
 
Upvote 0
Hi Jimmypop,

Thanks for testing and letting us know.

Please, try passing spaces instead of null strings as follows:
VBA Code: 
 Call SetWindowTheme(hToolTip, " ", " ")

Does that now remove the visual style and allow the colors to take effect ?
 
Upvote 0
Amazing! It's working for me again!
I misread your instructions slightly, though, thinking you had said to replace the vbNullstring with an empty string (rather than spaces) which I did. I ended up having to save the workbook, close it and reopen it again, but it's working again now. Thank you!

It is odd, isn't it, that it should all of the sudden stop working? I noticed that some UI code you had written (the userform menus, I think) had changed appearance too. I started a thread about it, but I can't seem to find it at the moment. Basically, the the menus appeared in dark theme whereas they hadn't previously. Yes, I have the dark theme enabled on my system, but I'm aware of the UI differences with the API-generated menus and CommandBar popups (Application.CommandBars v Application.VBE.Commanbars), and this was odd. I had wondered if this development was connected to that one too. I will try and dig it out and look again.


1660606414322.png
1660606429525.png
1660606450097.png
 
Upvote 0
Just for completeness, I found the thread I started, and I double checked with the workbooks again. It was looking like the one on the left, whereas now they're back to normal for some inexplicable reason. It shall remain a mystery! :-)

1660609006877.png
1660608904439.png
 
Upvote 0
JV0710 said:
Good Morning

Thanks very much for this - It will help me with some of my spreadsheets with process information

Is it possible to have changes made to the code that will allow the TAB information to be managed without going into the code

example: Have an "Tab info" sheet where for example
in Cell A1:D5 I can type the info for sheet 1
in Cell A7:D12 I can type the info for sheet 2
etc
The "Tab info" sheet can then be hidden

This will help to easily make changes to the "Baloons" without accessing the VBA code

Thanks

Joe
Click to expand...

You could do that by storing the value of each udt tooltip field in their respective cell in the hidden "tab info" sheet.
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

For example :
A1= SheetCodeName
A2= Title
A3= Text
etc

And then adjust the calling code as follows :
Dim oTip1 As ToolTip With oTip1 .SheetCodeName = Sheets(Tab info").Range("A1").Value & vbNullChar .Title = Sheets(Tab info").Range("A2").Value & vbNullChar .Text = Sheets(Tab info").Range("A3").Value & vbNullChar ... etc End With
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
Referencing all Running Instances Of Excel, Word and Access
2 3 4
Replies
32
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
MsgBox that waits for user input
2
Replies
14
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Controlling the System Sounds (Warnings, Notifications etc) via CoreAudio Interfaces.
Replies
1
Views
116
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Custom Accessibility Class
Replies
4
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
ScreenTips For Shapes and Buttons.
2
Replies
12
Views
3K
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

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