A Cool Generic ToolTip Class for Worksheet ActiveX Controls

[Jaafar Tribak]

Workbook Demo
Hi Excellers,
As the title says, this is a Class that creates ToolTips for worksheet controls .. The tooltips are made out of office AutoShapes

Some of its fun features :
1- Works for all controls except for Spin and ScrollBrar controls
2- You can create a tooltip for different controls at the same time still using the same class code
3- Works for controls located on different worksheets
4- Thanks to the rich Office shape Object model, the tooltips can be individually formatted as you wish : Text Font, BackGround, Shape, PlaySound,Transparency, Gradient, TimeOut ..etc

One expected problem though is the loss of Excel's Undo functionality whenever the tooltip is displayed

1- Code In the Class Module : (CControlToolTip):

Option Explicit

Private WithEvents cmb As MSForms.CommandButton
Private WithEvents TgglBtn As MSForms.ToggleButton
Private WithEvents TxtBx As MSForms.TextBox
Private WithEvents Lbl As MSForms.Label
Private WithEvents Img As MSForms.Image
Private WithEvents Listbx As MSForms.ListBox
Private WithEvents CmboBox As MSForms.ComboBox
Private WithEvents ChckBx As MSForms.CheckBox
Private WithEvents OptBtn As MSForms.OptionButton
Private WithEvents wb As Workbook

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, _
        ByVal uElapse As LongLong, _
        ByVal lpTimerFunc As LongLong) As LongLong
    Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal HWnd As LongLong, _
        ByVal nIDEvent As LongLong) As LongLong
    Private Declare PtrSafe Function MessageBeep Lib "user32"(ByVal wType As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" Alias "GetSysColor" ( _
        ByVal nIndex As Long) As Long
  #Else
    Private Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
    Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Const MB_ICONINFORMATION = &H40&
Private Const COLOR_INFOBK = 24
Private Const COLOR_INFOTEXT = 23

Private objToolTip As Shape
Private objOwnerControl As Object
Private sngTimeOut As Single
Private sngStartTime As Single
Private bPlaySound As Boolean
Private bError As Boolean
Private bTimerRunning As Boolean

Private Sub Class_Initialize()
    Set wb = ThisWorkbook
End Sub
Private Sub Class_Terminate()
    On Error Resume Next
    KillTimer Application.hwnd, ObjPtr(Me)
    objToolTip.Delete
    Set wb = Nothing
End Sub
Private Sub cmb_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub OptBtn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub ChckBx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub CmboBox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub Img_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub Lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub Listbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub TgglBtn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub TxtBx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    Call GenericMosueMoveMacro
End Sub
Private Sub GenericMosueMoveMacro()
    Dim lTimerId As Long
    On Error Resume Next
    If bTimerRunning = False Then
        If bPlaySound Then
            Call MessageBeep(MB_ICONINFORMATION)
        End If
        objToolTip.Visible = msoTrue
        bTimerRunning = True
        sngStartTime = Timer
        Call SetTimer(Application.hwnd, ObjPtr(Me), 1, AddressOf TimerRedirect)
    End If
End Sub
Private Sub wb_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    KillTimer Application.hwnd, ObjPtr(Me)
    objToolTip.Delete
End Sub
Public Sub DO_NOT_USE_THIS_METHOD() 'DO NOT CALL THIS PUBLIC CLASS METHOD !!!
    Dim tPt As POINTAPI
    On Error Resume Next
    GetCursorPos tPt
    If objOwnerControl.Name <> ActiveWindow.RangeFromPoint(tPt.x, tPt.Y).Name Then
        objToolTip.Visible = msoFalse
        KillTimer Application.hwnd, ObjPtr(Me)
        bTimerRunning = False
    Else
        bTimerRunning = True
    End If
    If Timer - sngStartTime >= sngTimeOut And sngTimeOut <> 0 Then
        objToolTip.Visible = msoFalse
    End If
End Sub


'*************************************************************************
'              PUBLIC CLASS PROPERTIIES AND METHODS
'*************************************************************************

Public Sub CreateNewInstance( _
    ByVal AssociatedControl As Object, _
    ByVal Left As Single, _
    ByVal Top As Single, _
    ByVal Width As Single, _
    ByVal Height As Single, _
    Optional ByVal ToolTipShape As MsoAutoShapeType = msoShapeRectangle _
    )

    On Error Resume Next
    AssociatedControl.Parent.Shapes(AssociatedControl.Name & "objToolTip").Delete
    KillTimer Application.hwnd, ObjPtr(Me)
    If bError Then Exit Sub
    Set objOwnerControl = AssociatedControl
    Select Case TypeName(AssociatedControl)
        Case "CommandButton"
            Set cmb = AssociatedControl
        Case "ToggleButton"
            Set TgglBtn = AssociatedControl
        Case "TextBox"
            Set TxtBx = AssociatedControl
        Case "Label"
            Set Lbl = AssociatedControl
        Case "Image"
            Set Img = AssociatedControl
        Case "ListBox"
            Set Listbx = AssociatedControl
        Case "ComboBox"
            Set CmboBox = AssociatedControl
        Case "CheckBox"
            Set ChckBx = AssociatedControl
        Case "OptionButton"
            Set OptBtn = AssociatedControl
    End Select
    Set objToolTip = AssociatedControl.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
    With objToolTip
        .Name = AssociatedControl.Name & "objToolTip"
        .Visible = msoFalse
        .Left = Left
        .Top = Top
        .Width = Width
        .Height = Height
        .AutoShapeType = ToolTipShape
    End With
End Sub

Public Sub AddText( _
    ByVal Text As String, _
    Optional ByVal FontName As Variant, _
    Optional ByVal FontSize As Variant, _
    Optional ByVal FontColor As Variant, _
    Optional ByVal FontBold As Boolean = False, _
    Optional ByVal FontItalic As Boolean = False, _
    Optional ByVal FontUnderline As Boolean = False, _
    Optional ByVal WrapText As Boolean = False _
    )
    
    On Error Resume Next
    If objOwnerControl Is Nothing And bError = False Then
        MsgBox "Failure to create the Tooltip" & vbCrLf & _
        "You have to create a new ToolTip Instance via the 'CreateNewInstance' Method before Adding text to the ToolTip" _
        , vbCritical, "Error!"
        bError = True
        Exit Sub
    End If
    With objToolTip.TextFrame2
        .TextRange.Text = Text
        If IsMissing(FontName) Then FontName = "Calibri"
        .TextRange.Characters.Font.Name = FontName
        If IsMissing(FontSize) Then FontSize = 11
        .TextRange.Characters.Font.Size = FontSize
        If IsMissing(FontColor) Then FontColor = GetSysColor(COLOR_INFOTEXT)
        .TextRange.Characters.Font.Fill.ForeColor.RGB = FontColor
        .TextRange.Characters.Font.Bold = FontBold
        .TextRange.Characters.Font.Italic = FontItalic
        If FontUnderline Then
            .TextRange.Characters.Font.UnderlineStyle = msoUnderlineSingleLine
        End If
        If WrapText Then
            .WarpFormat = msoWarpFormat1
            .WordWrap = msoTrue
            .AutoSize = msoAutoSizeShapeToFitText
        End If
    End With
End Sub

Public Sub FormatBackGround( _
Optional ByVal BackColor As Variant, _
Optional ByVal ApplyGradient As Boolean = False, _
Optional ByVal Transparency As Single = 0, _
Optional ByVal BordersVisible As Boolean = True, _
Optional ByVal ThreeD As Boolean = False)

    On Error Resume Next
    If objOwnerControl Is Nothing And bError = False Then
        MsgBox "Failure to create the Tooltip !" & vbCrLf & _
        "You have to create a new ToolTip Instance via the 'CreateNewInstance' Method before Formatting the ToolTip BackGround " _
        , vbCritical, "Error!"
        bError = True
        Exit Sub
    End If
    With objToolTip
        If IsMissing(BackColor) Then BackColor = GetSysColor(COLOR_INFOBK)
        .Fill.ForeColor.RGB = BackColor
        If ApplyGradient Then .Fill.OneColorGradient msoGradientVertical, 1, 1
        .Fill.Transparency = Transparency
        If ThreeD Then .ThreeD.BevelTopType = msoBevelCircle
        If BordersVisible = False Then .Line.Visible = msoFalse
    End With
End Sub

Public Property Let SecondsToTimeOut(ByVal vNewValue As Long)
    On Error Resume Next
    If objOwnerControl Is Nothing And bError = False Then
        MsgBox "Failure to create the Tooltip !" & vbCrLf & _
        "You have to create a new ToolTip Instance via the 'CreateNewInstance' Method before Setting Its 'TimeOut' Property", _
        vbCritical, "Error!"
        bError = True
        Exit Property
    End If
    sngTimeOut = vNewValue
End Property

Public Property Let PlaySound(ByVal vNewValue As Boolean)
    On Error Resume Next
    If objOwnerControl Is Nothing And bError = False Then
        MsgBox "Failure to create the Tooltip !" & vbCrLf & _
        "You have to create a new ToolTip Instance via the 'CreateNewInstance' Method before Setting Its 'PlaySound' Property", _
        vbCritical, "Error!"
        bError = True
        Exit Property
    End If
    bPlaySound = vNewValue
End Property

2- Test Code in a Standard Module: (4 Controls example :- CommandButton1,Image1,ComboBox1 and CheckBox1 all on Sheet1 )

Option Explicit

Private oToolTipsCollection As New Collection

Sub AddToolTips()
    Dim oToolTip1 As CControlToolTip
    Dim oToolTip2 As CControlToolTip
    Dim oToolTip3 As CControlToolTip
    Dim oToolTip4 As CControlToolTip

    Set oToolTip1 = New CControlToolTip
    With Sheet1.CommandButton1
        oToolTip1.CreateNewInstance AssociatedControl:=Sheet1.CommandButton1, Left:=.Left + .Width - 20 _
        , Top:=.Top + .Height, Width:=.Width * 1.5, Height:=.Height / 1.5, ToolTipShape:=msoShapeCloud
    End With
    With oToolTip1
        .SecondsToTimeOut = 2 'secs
        .FormatBackGround BackColor:=RGB(0, 200, 255), ApplyGradient:=True, ThreeD:=True
        .AddText Text:="Hello from " & Sheet1.CommandButton1.Name, WrapText:=True
        .PlaySound = True
    End With
    oToolTipsCollection.Add oToolTip1
    '_____________________________________________________________________________________________
    Set oToolTip2 = New CControlToolTip
    With Sheet1.Image1
        oToolTip2.CreateNewInstance AssociatedControl:=Sheet1.Image1, Left:=.Left + .Width + 5 _
        , Top:=.Top - 20, Width:=.Width * 2, Height:=.Height / 2
    End With
    With oToolTip2
        .SecondsToTimeOut = 4
        .FormatBackGround Transparency:=1, BordersVisible:=False
        .AddText Text:=Sheet1.Image1.Name & vbCrLf & _
        "Transparent ToolTip", FontColor:=vbBlue, FontItalic:=True, FontUnderline:=True
        .PlaySound = True
    End With
    oToolTipsCollection.Add oToolTip2
    '_______________________________________________________________________________________________
    Set oToolTip3 = New CControlToolTip
    With Sheet1.ComboBox1
        oToolTip3.CreateNewInstance AssociatedControl:=Sheet1.ComboBox1, Left:=.Left + .Width / 2 _
        , Top:=.Top + .Height + 5, Width:=.Width + 20, Height:=.Height, ToolTipShape:=msoShapeBalloon
    End With
    With oToolTip3
        .SecondsToTimeOut = 4
        .FormatBackGround BackColor:=vbYellow, ThreeD:=True
        .AddText "hello from " & Sheet1.ComboBox1.Name, FontSize:=14, FontName:="Harlow Solid Italic"
        .PlaySound = True
    End With
    oToolTipsCollection.Add oToolTip3
    '_________________________________________________________________________________________________
    Set oToolTip4 = New CControlToolTip
    With Sheet1.CheckBox1
        oToolTip4.CreateNewInstance AssociatedControl:=Sheet1.CheckBox1, Left:=.Left - .Width / 1.5 _
        , Top:=.Top + .Height + 5, Width:=.Width, Height:=.Height * 1.2
    End With
    With oToolTip4
        .FormatBackGround Transparency:=0.5
        .AddText "Silent, Semi-Transparent and Pesrsistent ToolTip "
    End With
    oToolTipsCollection.Add oToolTip4
End Sub

Sub RemoveToolTips()
    Set oToolTipsCollection = Nothing
End Sub

'******************************************************************
'=================
'   IMPORTANT !! '
'=================
'This Public Timer Procedure Must always be present
'in a *Standard Module*, because it is the SetTimer API
'CallBack which cannot be contained in a Class Module
'Also,this Procedure Must be left as-is and never be edited

Public Sub TimerRedirect()
    On Error Resume Next
    Dim oToolTip As CControlToolTip
    For Each oToolTip In oToolTipsCollection
        oToolTip.DO_NOT_USE_THIS_METHOD
    Next
End Sub

'********************************************************************

Written and tested on Excel 2007 only
Regards