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
Advertisement
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