Adding Multiline Balloon ToolTips to ListView Column Headers

Environment: Win 9X, 2K, XP

The attached code demonstrates a technique you can use to create multiline balloon ToolTips for ListView column headers.

The code uses a subclassing technique to trap the WM_MOUSEMOVE event of the Header control that is a constituent part of the ListView control. The handler for this event determines the index of the column header under the mouse pointer and changes the tooltip text respectively; it uses the HDM_HITTEST message for this purpose.

To find the handle of the Header control inside ListView from MSCOMCTL.OCX, the code uses the FindWindowEx function, which searches for the child window with the "msvb_lib_header" class inside the ListView control. The code also can be used to subclass the "pure" ListView control (its class name is "SysListView32"); to do it, you must replace the "msvb_lib_header" string on "SysHeader32".

The sample creates MS Windows ToolTips with the CreateWindowEx function passing to this function the "tooltips_class32" class name. Balloon ToolTips work only in Windows 2000/XP; in the previous versions of Windows, you'll see old-style rectangular ToolTips. You can use this technique to create multiline balloon ToolTips for any control that contains a Windows Header control. For instance, we use this technique to create such ToolTips for the grid control we produce (10Tec iGrid ActiveX control—visit www.10Tec.com for more info).

Class CToolTip

VERSION 1.0 CLASS
BEGIN
  MultiUse            = -1    'True
  Persistable         = 0     'NotPersistable
  DataBindingBehavior = 0     'vbNone
  DataSourceBehavior  = 0     'vbNone
  MTSTransactionMode  = 0     'NotAnMTSObject
END
Attribute VB_Name             = "CToolTip"
Attribute VB_GlobalNameSpace  = False
Attribute VB_Creatable        = True
Attribute VB_PredeclaredId    = False
Attribute VB_Exposed          = False
Attribute VB_Ext_KEY          = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY          = "Top_Level" ,"Yes"
Option Explicit

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" _
        (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, _
         pccolorref As Long) As Long
Private Const CLR_INVALID = -1

'Initialization of New ClassNames
Private Const ICC_BAR_CLASSES = &H4      'toolbar, statusbar,
                                         'trackbar, tooltips
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" _
        (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean

Private Type tagINITCOMMONCONTROLSEX
   dwSize As Long   ' size of this structure
   dwICC As Long    ' flags indicating which classes to be
                    ' initialized.
End Type

' ToolTip Styles
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX  = &H2
Private Const TTS_BALLOON   = &H40  ' comctl32.dll v5.8 required

Private Const CW_USEDEFAULT = &H80000000

Private Const WM_USER = &H400

' ToolTip Messages
Private Const TTM_SETDELAYTIME    = (WM_USER + 3)
Private Const TTM_ADDTOOL         = (WM_USER + 4)
Private Const TTM_DELTOOL         = (WM_USER + 5)
Private Const TTM_NEWTOOLRECT     = (WM_USER + 6)
Private Const TTM_GETTOOLINFO     = (WM_USER + 8)
Private Const TTM_SETTIPBKCOLOR   = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETMAXTIPWIDTH  = (WM_USER + 24)
Private Const TTDT_AUTOPOP        = 2
Private Const TTDT_INITIAL        = 3

Private Const TTM_TRACKACTIVATE   = (WM_USER + 17)
Private Const TTM_TRACKPOSITION   = (WM_USER + 18)
Private Const TTM_SETTOOLINFOA    = (WM_USER + 9)

Private Const TTF_IDISHWND        = &H1
Private Const TTF_CENTERTIP       = &H2
Private Const TTF_SUBCLASS        = &H10

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
    hwnd        As Long
    uId         As Long
    cRect       As RECT
    hinst       As Long
    lpszText    As String
End Type

Public Enum TTStyle
    ttStyleStandard = 1
    ttStyleBalloon  = 2
End Enum

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, l_
                                 pParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
                (ByVal hwnd 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 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 GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" (ByVal hwnd As Long, _
                                        ByVal nIndex As Long) _
                                                     As Long
Private Declare Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" (ByVal hwnd As Long, _
                                        ByVal nIndex As Long, _
                                        ByVal dwNewLong As Long) _
                                                        As Long
Private Const GWL_STYLE = (-16)
Private hTT As Long
Dim TI As TOOLINFO

Private mvarObjHwnd As Long    ' local copy

Public Property Let TxtColor(ByVal clrData As OLE_COLOR)
   SendMessageLong hTT, TTM_SETTIPTEXTCOLOR, _
                        TranslateColor(clrData), 0&
End Property

Public Property Let BkColor(ByVal clrData As OLE_COLOR)
   SendMessageLong hTT, TTM_SETTIPBKCOLOR, _
                        TranslateColor(clrData), 0&
End Property

Public Property Let VisibleTime(ByVal lData As Long)
   SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lData
End Property

Public Property Let DelayTime(ByVal lData As Long)
   SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, lData
End Property

Public Property Let TipWidth(ByVal lData As Long)
   SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, lData
End Property

Public Property Let Style(ByVal ttsData As TTStyle)
   Dim lStyle As Long
   If hTT Then
      lStyle = GetWindowLong(hTT, GWL_STYLE)
      If ttsData = ttStyleBalloon Then lStyle = lStyle Or _
                                                TTS_BALLOON
      If ttsData = ttStyleStandard _
         And (lStyle And ttStyleBalloon) _
         Then lStyle = lStyle Xor TTS_BALLOON
      SetWindowLong hTT, GWL_STYLE, lStyle
   End If
End Property

Private Sub InitComctl32(dwFlags As Long)
   Dim icc As tagINITCOMMONCONTROLSEX
   On Error GoTo Err_OldVersion
   icc.dwSize = Len(icc)
   icc.dwICC = dwFlags
   InitCommonControlsEx icc
   On Error GoTo 0
   Exit Sub
Err_OldVersion:
   InitCommonControls
End Sub

Public Sub InitToolTip(ByVal ObjHwnd As Long, _
           Optional ByVal sTipText As String = "tooltip", _
           Optional bCenter As Boolean = False)
   mvarObjHwnd = ObjHwnd
   
   With TI
      .hwnd      = mvarObjHwnd
      .uFlags    = TTF_IDISHWND Or TTF_SUBCLASS
      If bCenter Then
         .uFlags = .uFlags Or TTF_CENTERTIP
      End If
      .uId       = mvarObjHwnd
      .lpszText  = sTipText
      .cbSize    = Len(TI)
   End With
   SendMessage hTT, TTM_ADDTOOL, 0, TI
End Sub

Public Sub RemoveToolTip()
   SendMessage hTT, TTM_DELTOOL, 0, TI
End Sub

Private Sub Class_Initialize()
   InitComctl32 ICC_BAR_CLASSES
   hTT = CreateWindowEx(0, "tooltips_class32", 0&, _
                        TTS_NOPREFIX Or TTS_ALWAYSTIP, _
                        CW_USEDEFAULT, _
                        CW_USEDEFAULT, _
                        CW_USEDEFAULT, _
                        CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
   Style = ttStyleStandard
   TipWidth = 3000    ' Specify tip width to enable multiline
                      ' ToolTip
End Sub

Private Sub Class_Terminate()
   If hTT Then DestroyWindow hTT
End Sub

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                 Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Public Sub TrackPosition(ByVal x As Integer, ByVal y As Integer)
   SendMessageLong hTT, TTM_TRACKPOSITION, 0&, y * 65536 + x
End Sub

Public Sub ActivateTracking()
   SendMessage hTT, TTM_TRACKACTIVATE, 1, TI
End Sub

Public Sub DeactivateTracking()
   SendMessage hTT, TTM_TRACKACTIVATE, 0, TI
End Sub

Public Sub SetTooltipText(sText As String)
   TI.lpszText = sText
   SendMessage hTT, TTM_SETTOOLINFOA, 0&, TI
End Sub

Module mSubclass

Attribute VB_Name = "mSubclass"
Option Explicit

Public Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal lpPrevWndFunc As Long, _
        ByVal hwnd As Long, _
        ByVal Msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" _
        (ByVal hwnd As Long, _
         ByVal nIndex As Long, _
         ByVal dwNewLong As Long) As Long

Private Const GWL_WNDPROC  = -4

Private Const WM_MOUSEMOVE = &H200

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 Type POINTAPI
    x As Long
    y As Long
End Type

Private Type HDHITTESTINFO
    pt As POINTAPI
    flags As Long
    iItem As Long
End Type
Private Const HDM_FIRST    = &H1200
Private Const HDM_HITTEST  = HDM_FIRST + 6
Private Const HDM_GETITEMA = (HDM_FIRST + 3)
Private Const HDM_GETITEM  = HDM_GETITEMA

Private Type HD_ITEM
    mask As Long
    cxy As Long
    pszText As String
    hbm As Long
    cchTextMax As Long
    fmt As Long
    lParam As Long
    ' 4.70:
    iImage As Long
    iOrder As Long
End Type
Private Const HDI_LPARAM = &H8

Private Type TLoHiLong
   Lo As Integer
   Hi As Integer
End Type
Private Type TAllLong
   All As Long
End Type
Dim mLH As TLoHiLong, mAL As TAllLong


Private m_lPrevWndProc As Long
Private m_lCurHdrItem As Long

Public Sub Hook(ByVal pHwnd As Long)
   m_lPrevWndProc = SetWindowLong(pHwnd, GWL_WNDPROC, _
                                  AddressOf WindowProc)
   m_lCurHdrItem = -1
End Sub

Public Sub Unhook(ByVal pHwnd As Long)
   SetWindowLong pHwnd, GWL_WNDPROC, m_lPrevWndProc
End Sub

Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, _
         ByVal wParam As Long, ByVal lParam As Long) As Long
   
   Dim hti As HDHITTESTINFO
   Dim lCol As Long
   
   If uMsg = WM_MOUSEMOVE Then
      ' The low and high words of lParam contains x and y
      ' coordinates of the mouse pointer respectively:
      mAL.All = lParam
      LSet mLH = mAL
      hti.pt.x = mLH.Lo
      hti.pt.y = mLH.Hi
      ' retrieving the index of the header item under the
      ' mouse pointer:
      SendMessage hwnd, HDM_HITTEST, 0&, hti
      ' if the current header changed...
      If hti.iItem <> m_lCurHdrItem Then
         m_lCurHdrItem = hti.iItem
         Form1.TT.RemoveToolTip
         If m_lCurHdrItem <> -1 Then
            Form1.TT.InitToolTip hwnd, "Multiline tooltip" & _
                                        vbCrLf & "for " & _
            Form1.ListView1.ColumnHeaders(m_lCurHdrItem + 1)
         End If
      End If
   End If
   
   WindowProc = CallWindowProc(m_lPrevWndProc, hwnd, uMsg, _
                               wParam, lParam)
End Function

Demonstration Form

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; _
         "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption            =   "Form1"
   ClientHeight       =   3195
   ClientLeft         =   60
   ClientTop          =   345
   ClientWidth        =   5745
   LinkTopic          =   "Form1"
   ScaleHeight        =   3195
   ScaleWidth         =   5745
   StartUpPosition    =   3    'Windows Default
   Begin MSComctlLib.ListView ListView1 
      Height          =   2595
      Left            =   120
      TabIndex        =   0
      Top             =   300
      Width           =   5475
      _ExtentX        =   9657
      _ExtentY        =   4577
      View            =   3
      LabelWrap       =   -1    'True
      HideSelection   =   -1    'True
      AllowReorder    =   -1    'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   3
      BeginProperty ColumnHeader(1) _
                    {BDD1F052-858B-11D1-B16A-00C0F0283628}
         Text                   =   "Column 1"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) _
                    {BDD1F052-858B-11D1-B16A-00C0F0283628}
         SubItemIndex           =   1
         Text                   =   "Column 2"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(3) _
                    {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex           =   2
         Text                   =   "Column 3"
         Object.Width           =   2540
      EndProperty
   End
End
Attribute VB_Name               = "Form1"
Attribute VB_GlobalNameSpace    = False
Attribute VB_Creatable          = False
Attribute VB_PredeclaredId      = True
Attribute VB_Exposed            = False
Option Explicit

Private Declare Function FindWindowEx Lib "user32" _
                Alias "FindWindowExA" _
                (ByVal hWndParent As Long, _
                 ByVal hwndChildAfter As Long, _
                 ByVal lpszClass As String, _
                 ByVal lpszWindow As String) As Long

Dim m_HdrHwnd As Long
Public TT As CToolTip

Private Sub Form_Load()
   m_HdrHwnd = FindWindowEx(ListView1.hwnd, 0, _
                            "msvb_lib_header", vbNullString)
   Hook m_HdrHwnd
   
   Set TT = New CToolTip
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Unhook m_HdrHwnd
End Sub

Downloads