Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- 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
1- Class Code ( Class name is : clsTabTips)
2- Code Usage Example in a Standard Module:
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 Sub2- 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
