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 ExplicitPrivate 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 BooleanPrivate 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 requiredPrivate 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 = 3Private 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 = &H10Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePrivate Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
cRect As RECT
hinst As Long
lpszText As String
End TypePublic Enum TTStyle
ttStyleStandard = 1
ttStyleBalloon = 2
End EnumPrivate 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 TOOLINFOPrivate mvarObjHwnd As Long ‘ local copy
Public Property Let TxtColor(ByVal clrData As OLE_COLOR)
SendMessageLong hTT, TTM_SETTIPTEXTCOLOR, _
TranslateColor(clrData), 0&
End PropertyPublic Property Let BkColor(ByVal clrData As OLE_COLOR)
SendMessageLong hTT, TTM_SETTIPBKCOLOR, _
TranslateColor(clrData), 0&
End PropertyPublic Property Let VisibleTime(ByVal lData As Long)
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lData
End PropertyPublic Property Let DelayTime(ByVal lData As Long)
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, lData
End PropertyPublic Property Let TipWidth(ByVal lData As Long)
SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, lData
End PropertyPublic 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 PropertyPrivate 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 SubPublic Sub InitToolTip(ByVal ObjHwnd As Long, _
Optional ByVal sTipText As String = “tooltip”, _
Optional bCenter As Boolean = False)
mvarObjHwnd = ObjHwndWith 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 SubPublic Sub RemoveToolTip()
SendMessage hTT, TTM_DELTOOL, 0, TI
End SubPrivate 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 SubPrivate Sub Class_Terminate()
If hTT Then DestroyWindow hTT
End SubPrivate 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 FunctionPublic Sub TrackPosition(ByVal x As Integer, ByVal y As Integer)
SendMessageLong hTT, TTM_TRACKPOSITION, 0&, y * 65536 + x
End SubPublic Sub ActivateTracking()
SendMessage hTT, TTM_TRACKACTIVATE, 1, TI
End SubPublic Sub DeactivateTracking()
SendMessage hTT, TTM_TRACKACTIVATE, 0, TI
End SubPublic 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