Adding real Win32 tooltips for windowless controls

The attached code demonstrates an idea you can use to create real Win32 tooltips for windowless controls. The problem with Win32 tooltips is that you can attach it only to a control that provides the hwnd property returning the Win32 handle of the control. Some VB intrinsic controls such as Label do not have the hwnd property. The following trick allows you to create real Windows tooltips for these controls.

To do it, simply determine the moment when the mouse pointer has entered the area occupied by the required control, and create a tooltip for the FORM that contains the control. You need to detach the created tooltip from the form when the mouse pointer has left the control area; you can do it in the Form_MouseMove method.
The attached example shows how to create a multiline balloon tooltip for a Label control. Using this technique, you can create tooltips for any control that implements the MouseMove event (for instance, for Image control too).

First, the code for the form, which has a label called Label1 for which we will provide the tooltip.

Option Explicit
Dim TT As CTooltip
Dim m_bInLable As Boolean
Private Sub Form_Load()
Set TT = New CTooltip
TT.Style = TTBalloon
TT.Icon = TTIconInfo
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If m_bInLable Then
    m_bInLable = False
    TT.Destroy
End If
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not m_bInLable Then
    m_bInLable = True
    TT.Title = "Multiline tooltip"
    TT.TipText = "Label1"
    TT.Create Me.hwnd
End If
End Sub

And now, the class (named CTooltip)

Option Explicit
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
''Windows API Functions
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
''Windows API Constants
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
''Windows API Types
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
''Tooltip Window Constants
Private Const TTS_NOPREFIX = &H2
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTS_ALWAYSTIP = &H1
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
''Tooltip Window Types
Private Type TOOLINFO
    lSize As Long
    lFlags As Long
    hwnd As Long
    lId As Long
    lpRect As RECT
    hInstance As Long
    lpStr As String
    lParam As Long
End Type

Public Enum ttIconType
    TTNoIcon = 0
    TTIconInfo = 1
    TTIconWarning = 2
    TTIconError = 3
End Enum
Public Enum ttStyleEnum
    TTStandard
    TTBalloon
End Enum
'local variable(s) to hold property value(s)
Private mvarBackColor As Long
Private mvarTitle As String
Private mvarForeColor As Long
Private mvarIcon As ttIconType
Private mvarCentered As Boolean
Private mvarStyle As ttStyleEnum
Private mvarTipText As String
Private mvarVisibleTime As Long
Private mvarDelayTime As Long
'private data
Private m_lTTHwnd As Long ' hwnd of the tooltip
Private m_lParentHwnd As Long ' hwnd of the window the tooltip attached to
Private ti As TOOLINFO
Public Property Let Style(ByVal vData As ttStyleEnum)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Style = 5
mvarStyle = vData
End Property
Public Property Get Style() As ttStyleEnum
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Style
Style = mvarStyle
End Property
Public Property Let Centered(ByVal vData As Boolean)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Centered = 5
mvarCentered = vData
End Property
Public Property Get Centered() As Boolean
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Centered
Centered = mvarCentered
End Property
Public Function Create(ByVal ParentHwnd As Long) As Boolean
Dim lWinStyle As Long

If m_lTTHwnd <> 0 Then
    DestroyWindow m_lTTHwnd
End If

m_lParentHwnd = ParentHwnd

lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX

''create baloon style if desired
If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON
   
m_lTTHwnd = CreateWindowEx(0&, _
    TOOLTIPS_CLASSA, _
    vbNullString, _
    lWinStyle, _
    CW_USEDEFAULT, _
    CW_USEDEFAULT, _
    CW_USEDEFAULT, _
    CW_USEDEFAULT, _
    0&, _
    0&, _
    App.hInstance, _
    0&)
           
''now set our tooltip info structure
With ti
    ''if we want it centered, then set that flag
    If mvarCentered Then
        .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND
    Else
        .lFlags = TTF_SUBCLASS Or TTF_IDISHWND
    End If
   
    ''set the hwnd prop to our parent control's hwnd
    .hwnd = m_lParentHwnd
    .lId = m_lParentHwnd '0
    .hInstance = App.hInstance
    '.lpstr = ALREADY SET
    '.lpRect = lpRect
    .lSize = Len(ti)
End With

''add the tooltip structure
SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti
''if we want a title or we want an icon
If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then
    SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
End If
If mvarForeColor <> Empty Then
    SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
End If
If mvarBackColor <> Empty Then
    SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
End If

SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, mvarVisibleTime
SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, mvarDelayTime
End Function
Public Property Let Icon(ByVal vData As ttIconType)
mvarIcon = vData
If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
    SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
End If
End Property
Public Property Get Icon() As ttIconType
Icon = mvarIcon
End Property
Public Property Let ForeColor(ByVal vData As Long)
mvarForeColor = vData
If m_lTTHwnd <> 0 Then
    SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
End If
End Property
Public Property Get ForeColor() As Long
ForeColor = mvarForeColor
End Property
Public Property Let Title(ByVal vData As String)
mvarTitle = vData
If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
    SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
End If
End Property
Public Property Get Title() As String
Title = ti.lpStr
End Property
Public Property Let BackColor(ByVal vData As Long)
mvarBackColor = vData
If m_lTTHwnd <> 0 Then
    SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
End If
End Property
Public Property Get BackColor() As Long
BackColor = mvarBackColor
End Property
Public Property Let TipText(ByVal vData As String)
mvarTipText = vData
ti.lpStr = vData
If m_lTTHwnd <> 0 Then
    SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti
End If
End Property
Public Property Get TipText() As String
TipText = mvarTipText
End Property
Private Sub Class_Initialize()
InitCommonControls
mvarDelayTime = 500
mvarVisibleTime = 5000
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
Public Sub Destroy()
If m_lTTHwnd <> 0 Then
    DestroyWindow m_lTTHwnd
End If
End Sub
Public Property Get VisibleTime() As Long
VisibleTime = mvarVisibleTime
End Property
Public Property Let VisibleTime(ByVal lData As Long)
mvarVisibleTime = lData
End Property
Public Property Get DelayTime() As Long
DelayTime = mvarDelayTime
End Property
Public Property Let DelayTime(ByVal lData As Long)
mvarDelayTime = lData
End Property

You might also like...

Comments

10Tec Company

Contribute

Why not write for us? Or you could submit an event or a user group in your area. Alternatively just tell us what you think!

Our tools

We've got automatic conversion tools to convert C# to VB.NET, VB.NET to C#. Also you can compress javascript and compress css and generate sql connection strings.

“Hofstadter's Law: It always takes longer than you expect, even when you take into account Hofstadter's Law.”