Private Declare Sub InitCommonControls Lib "comctl32" ()
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 DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private myHoverTime As Long 'time im millisecs (-1 = use default)
Private myPopupTime As Long 'time im millisecs (-1 = use default)
Private myInitialText As Variant 'has the initial text
Private myInitialTitle As Variant 'has the initial title
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER As Long = &H400
Private Const TTM_SETDELAYTIME As Long = WM_USER + 3
Private Const TTM_ADDTOOL As Long = WM_USER + 4
Private Const TTM_SETTIPBKCOLOR As Long = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR As Long = WM_USER + 20
Private Const TTM_SETTITLE As Long = WM_USER + 32
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECTANGLE) As Long
Private Type RECTANGLE
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type ToolInfo
ttSize As Long
myFlags As Long
ttParhWnd As Long
ttId As Long
ParentRect As RECTANGLE
hInstance As Long
myText As String
lParam As Long
End Type
Private ToolInfo As ToolInfo
Attribute ToolInfo.VB_VarDescription = "Tool information structure."
'tool property flag bits meaning
Private Const TTF_CENTERTIP As Long = 2 'center tool on parent
Attribute TTF_CENTERTIP.VB_VarDescription = "Win API constant."
Private Const TTF_SUBCLASS As Long = &H10 'use implicit subclassing
Attribute TTF_SUBCLASS.VB_VarDescription = "Win API constant."
Public Property Get BackCol() As Long
Attribute BackCol.VB_Description = "Returns the current tooltip backcolor."
'this returns the current tooltip backcolor
BackCol = myBackColor
End Property
Public Property Get Centered() As Boolean
Attribute Centered.VB_Description = "Returns the current tooltip alignment."
'this returns the current tooltip alignment
Centered = CBool(ToolInfo.myFlags And TTF_CENTERTIP)
End Property
Private Sub Class_Initialize()
InitCommonControls 'doesn't matter that this is called for every class instance
myStyle = TTNone
End Sub
Private Sub Class_Terminate()
'kill tooltip window if one exists
If TThWnd Then
DestroyWindow TThWnd
TThWnd = 0
End If
myStyle = TTNone
End Sub
Public Function Create(Parent As Control, _
Text As String, _
Optional ByVal Style As TTStyle = TTBalloonAlways, _
Optional ByVal Centered As Boolean = False, _
Optional ByVal Icon As TTIcon = TTIconNone, _
Optional Title As String = "", _
Optional ByVal ForeColor As Long = vbButtonText, _
Optional ByVal BackColor As Long = vbInfoBackground, _
Optional ByVal HoverTime As Long = -1, _
Optional ByVal PopupTime As Long = -1) As Long
'Create the tooltip window for parent control that has an hWnd
'This can now also create custom tooltips for hWnd-less controls,
'just supply a fake hWnd (normally the containing form.hWnd) for windowless controls
Class_Terminate 'kill tooltip window if one exists
With ToolInfo
On Error Resume Next
.ttParhWnd = Parent.hWnd 'the control's hWnd
If Err Then 'has no hWnd
Err.Clear
.ttParhWnd = Parent.Parent.hWnd
End If
If (Err = 0) And _
(Style = TTBalloonAlways Or Style = TTStandardAlways Or Style = TTBalloonIfActive Or Style = TTStandardIfActive) And _
(Icon = TTIconError Or Icon = TTIconInfo Or Icon = TTIconNone Or Icon = TTIconWarning) Then
'the tooltip parent control has an hWnd and the params are acceptable
.ttSize = Len(ToolInfo)
.myFlags = TTF_SUBCLASS Or IIf(Centered, TTF_CENTERTIP, 0&)
GetClientRect .ttParhWnd, .ParentRect
.hInstance = App.hInstance
myTitle = Title
If myInitialTitle = Empty Then
myInitialTitle = myTitle
End If
.myText = Replace$(Text, "|", vbCrLf) 'the vertical bar is used as line break character
