Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,846
- Office Version
- 2016
- Platform
- Windows
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):
2- Test Code in a Standard Module: (4 Controls example :- CommandButton1,Image1,ComboBox1 and CheckBox1 all on Sheet1 )
Written and tested on Excel 2007 only
Regards
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):
Code:
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 )
Code:
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