Tooltips for a listbox

[dcanham]

Is there a way to have a tooltip for each individual item in a listbox. I know how to have a tooltip for the overall list box object, but not for the individual line items.

 

[Norie]

Short answer - no.

There could be some magical way to do it with windows API or something but I would imagine if at all possible it would need a fair amount of code.

 

[Smitty]

Norie, might you be able to rig the ListBox change event to throw up a label for each item?

 

[Norie]

Smitty

I think it might be possible but I'm not sure.

Something like this perhaps.

Option Explicit
Private Sub ListBox1_Change()
    ListBox1.ControlTipText = ListBox1.List(ListBox1.ListIndex)
End Sub
 

Private Sub UserForm_Initialize()
Dim I As Long
    For I = 1 To 10
        ListBox1.AddItem I
    Next I
End Sub

Just tried that and it did change the tooltip (actually ControlTipText) but, for me anyway, the results weren't very good.

Had to keep on moving focus to get the tip to display, which might be the default behaviour, and moving focus to what/when didn't seem to follow any logic.

I've doing things before with individual items in a listbox/combobox but never really got any satisfactory results.

I suppose it's just one of those things you have to put up with when using 'standard' controls.

I still can't get over the fact you need to loop through the list of a multiselect to get the selections.

In Access you can use the ItemsSelected property and in 'proper' VB I'm sure there's something similar.

 

[dcanham]

Thanks for trying people. There are some VB examples out there but none of them translated well into Excel user forms. I was jut hoping that one of you geniuses might have come up with a clever way of doing that.

 

[mikerickson]

Perhaps something like this:

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    With ListBox1
        Select Case y
            Case Is < 15
                .ControlTipText = "Msg1"
            Case Is < 30
                .ControlTipText = "Msg2"
            Case Is < 45
                .ControlTipText = "Msg3"
            Case Else
                .ControlTipText = "test"
        End Select
    End With
End Sub

Like Norie, I had trouble getting the tool tip twice per focus. Smitty's idea of a message showing when an item is selected might be a smoother user interface.

 

[Jaafar Tribak]

Here is something similar for comboboxes but as Norie mentioned, it involves a fair amount of code .

I am a bit busy right now , if you are still interested i'll see if i can adapt it to work for a listbox.

Is your Listbox on a worksheet or on a UserForm ?

Regards.

 

[dcanham]

It is on a user form.

 

[Jaafar Tribak]

I have adapted the code to work for a ListBox.

See this WorkBook Demo.

here is the whole vb project code:

Proceedings :

1- Place this in the UserForm module (this just populates the listbox with the alphabet)

Option Explicit
 
Private Sub UserForm_Initialize()
    Dim i As Long
    
    [COLOR=seagreen]'Populate the Listbox.[/COLOR]
    With Me.ListBox1
     .AddItem Chr(65)
    For i = 1 To 25
        .AddItem .List(i - 1) & "  " & Chr(65 + i)
    Next
     .ListIndex = 0
    End With
    Me.Caption = "tooltips for a listbox demo."
 
End Sub

2- Place this in a Standard module (Main code)

Option Explicit
 
[COLOR=seagreen]'**** global variables ****
[/COLOR]Public oLbx As MSForms.ListBox
Public arTemp() As String
Public sMessageString As String
Public ToolTipHeight As Single
Public FontHeight As Single
Public FontWidth As Single
Public WidthFactor As Single
Public LbxYpointer As Single
Public LbxXpointer As Single
Public ToolTiphwnd As Long
Public lRow As Long
[COLOR=seagreen]'***********************[/COLOR]
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) 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 SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
 
 
Private Declare Function DrawEdge Lib "user32" _
(ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long
 
 
Private Declare Function DrawText Lib "user32" _
Alias "DrawTextA" _
(ByVal hdc As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat 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 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 GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "User32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, ByVal hBrush As Long) As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
 
Private Declare Function BeginPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function EndPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
 
Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
lprcUpdate As Any, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
 
 
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
 
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
 
Private Declare Function GetClientRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
  
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 ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Declare Function GetDesktopWindow Lib "user32" _
() As Long
 
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = _
(BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = _
(BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const DT_LEFT = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_NOCLIP = &H100

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_CHILD = &H40000000
Private Const SS_CENTER = &H1
Private Const SW_HIDE = &H0
Private Const SW_NORMAL = 1
Private Const EM_GETLINECOUNT = &HBA

Private Const ES_MULTILINE As Long = &H4
Private Const ES_LEFT As Long = &H0
Private Const ES_READONLY = &H800&
Private Const TOLLTIP_COLOR = &HE1FFFF
Private Const RDW_INTERNALPAINT = &H2
Private Const WM_PAINT = &HF
Private Const WM_DESTROY = &H2
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOVE = &H3
Private lPrevWnd As Long
Private lhdc As Long
Private oToolTip  As ToolTip
Private uClientArea As RECT
   
Public Function CallBack _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    
    Dim uFont As LOGFONT
    Dim lFHwnd, lOldFont As Long
    Dim uP As POINTAPI
    
    On Error Resume Next
    
    [COLOR=seagreen]'store the tolltip ctl area to be painted.[/COLOR]
    GetClientRect hwnd, uClientArea
    
    [COLOR=seagreen]'catch the paint and move msgs.[/COLOR]
    Select Case Msg
    
        Case WM_PAINT
        
            With uClientArea
            Call DrawRect _
            (hwnd, .Left, .Top, .Right - .Left, _
            .Bottom - .Top, TOLLTIP_COLOR)
            End With
            ToolTipHeight = GetLineCount(ToolTiphwnd) * FontHeight
            
        Case WM_MOVE
        
           [COLOR=seagreen] 'create a new font for the tooltip ctl text.[/COLOR]
            With uFont
            .lfFaceName = "Arial" & Chr$(0)
            .lfHeight = 16 ' change these font values as required
            .lfWidth = 6 '
           [COLOR=seagreen] 'store the width and height in public vars
[/COLOR]            [COLOR=seagreen]'so they can be used to set the dims of the tooltip
[/COLOR]            [COLOR=seagreen]'ctl in the tooltip module.[/COLOR]
            FontHeight = .lfHeight
            FontWidth = .lfWidth
            End With
            lFHwnd = CreateFontIndirect(uFont)
            lOldFont = SelectObject(lhdc, lFHwnd)
            SetBkMode lhdc, 1
            
            [COLOR=seagreen]'redraw the tooltip ctl each time a new row of the[/COLOR]
            [COLOR=seagreen]'listbox ia highlighted by the mouse pointer.
[/COLOR]            If lRow <> Int(LbxYpointer \ (8 + 2)) _
            + oLbx.TopIndex Then
            lRow = Int((LbxYpointer) \ (8 + 2)) _
            + oLbx.TopIndex
            Call ShowText(hwnd, lRow)
            SendMessage hwnd, WM_PAINT, 0, 0
            End If
            DrawEdge lhdc, uClientArea, EDGE_ETCHED, BF_RECT
            
            [COLOR=seagreen]'draw the text for each highlighted listbox row.[/COLOR]
            DrawText lhdc, sMessageString, _
            Len(sMessageString), uClientArea, _
            DT_NOCLIP + DT_LEFT + DT_WORDBREAK
            
        Case WM_DESTROY
        
            [COLOR=seagreen]'Remove the wnd Subclassing.[/COLOR]
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
            ReleaseDC hwnd, lhdc
            
    End Select
        
    [COLOR=seagreen]'cleanup to avoid memory leaks!
[/COLOR]    SelectObject lhdc, lOldFont
    DeleteObject lFHwnd
    
    [COLOR=seagreen]'pass other msgs to def proc.
[/COLOR]    CallBack = CallWindowProc _
    (lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
 
End Function
 
Private Sub DrawRect _
(lhwnd As Long, Left, Top, width, Height, MyColor)
 
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tR As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
 
    BeginPaint lhwnd, tPS
    tLB.lbColor = MyColor
   [COLOR=seagreen]'Create a new brush.[/COLOR]
    hBrush = CreateBrushIndirect(tLB)
    SetRect tR, Left, Top, width, Height
    [COLOR=seagreen]'Fill the tooltip with our brush.
[/COLOR]    FillRect lhdc, tR, hBrush
    Call DeleteObject(hBrush)
    RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
    Call EndPaint(lhwnd, tPS)
 
End Sub
 
Sub CreateToolTipCtl()
    
   [COLOR=seagreen] 'here we create the tooltip.[/COLOR]
    With GetCursorPosition
        ToolTiphwnd = CreateWindowEx(WS_EX_TOOLWINDOW, "EDIT", _
        vbNullString, ES_MULTILINE + ES_LEFT + _
        ES_READONLY + WS_CHILD, .x, .y, 0, _
        0, GetDesktopWindow, 0, 0, 0)
    End With
    
    [COLOR=seagreen]'store the tooltip DC in a module level var.[/COLOR]
    lhdc = GetDC(ToolTiphwnd)
    
End Sub
 
Sub SubclassToolTip()
 
    [COLOR=seagreen]'let's subclass the tooltip here to intercept its wnd msgs.
[/COLOR]    lPrevWnd = SetWindowLong _
    (ToolTiphwnd, GWL_WNDPROC, AddressOf CallBack)
    
End Sub
 
Function GetCursorPosition() As POINTAPI
 
    Dim tP As POINTAPI
 
    GetCursorPos tP
    GetCursorPosition = tP
    
End Function
 
 
Sub ShowWnd(hwnd As Long, Visible As Long)
 
    ShowWindow hwnd, Visible
 
End Sub
 
Sub SetToolTipPos _
(hwnd As Long, Left As Long, Top As Long)
 
    [COLOR=seagreen]'change thse constantes to suit.
[/COLOR]    Const OffsetX = -30
    Const OffsetY = 25
    
    SetWindowPos hwnd, 0, Left + OffsetX, Top + OffsetY, _
    FontWidth * WidthFactor, ToolTipHeight + 2, 0
  
End Sub
 
Sub DestroyToolTip()
 
    DestroyWindow ToolTiphwnd
    
End Sub
 
Function GetLineCount(hwnd As Long) As Long
 
    GetLineCount = SendMessage _
    (hwnd, EM_GETLINECOUNT, ByVal 0, ByVal 0) - 1
 
End Function
 
Private Sub ShowText(ByVal hwnd, ByVal row As Long)
 
    sMessageString = arTemp(CStr(row + 1))
    SetWindowText hwnd, sMessageString
 
End Sub

Sub AttachToolTipToListBox(Lbx As MSForms.ListBox)
 
    Const lRowsNumber As Long = 26 [COLOR=seagreen]'==>this Const should match the[/COLOR]
    Dim i             As Long      [COLOR=seagreen]'# of rows of the listbox !! !
[/COLOR]    Dim sToolTipText  As String
    Dim sTextArray(lRowsNumber) As String
 
[COLOR=seagreen]    '**********************[/COLOR]
   [COLOR=seagreen]'first, let's start the setup work for the tooltip text.
[/COLOR] 
   [COLOR=seagreen]'get the text for each lisbox row[/COLOR]
  [COLOR=seagreen] 'and add them to a string array.[/COLOR]
    For i = 1 To lRowsNumber
        sTextArray(i) = "This is the text for Item # : " & _
         i & vbNewLine & Lbx.List(i - 1)
    Next i
 
    [COLOR=seagreen]'ok, we are now done with the setup work[/COLOR]
   [COLOR=seagreen] 'so, let's create a new ToolTip instance now.[/COLOR]
    Set oToolTip = New ToolTip
 
    [COLOR=seagreen]'plug the tooltip into the listbox & set its attributes.[/COLOR]
    With oToolTip
        .CreateToolTip Form:=Lbx.Parent, ListBox:=Lbx, _
        ListRows:=lRowsNumber, TextArray:=sTextArray(), _
        ToolTipWidth:=30
    End With
 
    [COLOR=seagreen]'display the userform that contains the listbox.[/COLOR]
    Lbx.Parent.Show
 
    [COLOR=seagreen]'important to avoid crashing XL !!!![/COLOR]
    Set oToolTip = Nothing
 
End Sub

3- Create a Class module ,give the Class the name of ToolTip and place this code in it's module :

Option Explicit
 
Private WithEvents Frm_events As UserForm
Private WithEvents Lbx_events As MSForms.ListBox

Private Sub Class_Terminate()
 
   [COLOR=seagreen] 'cleanup.
[/COLOR]    Call DestroyToolTip
 
End Sub
 
Private Sub Lbx_events_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
 
    [COLOR=seagreen]'store the X,Y mouse coordinates in a global var.[/COLOR]
    LbxYpointer = y
    LbxXpointer = x
    
    [COLOR=seagreen]'compute the height of the toolttip according to the # of lines.[/COLOR]
    ToolTipHeight = GetLineCount(ToolTiphwnd) * FontHeight
    If ToolTipHeight = 0 Then ToolTipHeight = FontHeight * 2
    
    With GetCursorPosition
        Call SetToolTipPos(ToolTiphwnd, .x, .y)
    End With
    Call ShowWnd(ToolTiphwnd, 1)
 
End Sub

Private Sub Frm_events_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
 
    If lRow = 0 Then sMessageString = arTemp(1)
    'hide the tooltip if the mouse exits the listbox.
    Call ShowWnd(ToolTiphwnd, 0)
 
End Sub

Sub CreateToolTip _
(Form As UserForm, ListBox As MSForms.ListBox, TextArray() As String, _
ListRows As Long, ToolTipWidth As Double)
 
    [COLOR=seagreen]'store the params in module level variables.[/COLOR]
    arTemp() = TextArray()
    WidthFactor = ToolTipWidth
    
    Set Frm_events = Form
    Set Lbx_events = ListBox
    
    [COLOR=seagreen]'hook the listbox here.[/COLOR]
    Set oLbx = Lbx_events
    
   [COLOR=seagreen] 'create the tooltip ctl here and subclass it.
[/COLOR]    Call CreateToolTipCtl
    Call SubclassToolTip
 
End Sub

4- Finally to attach the tooltip to your listbox you can do it as simply as the following call :

Sub Test()
 
    Call AttachToolTipToListBox(UserForm1.ListBox1)

End Sub

As you can see , just to have something as simple and as common as a tooltip one needs to resort to the windows API and use tons of code ! Anyway it was fun to code

Regards.

 

[dcanham]

wow thanks!! I will plug this into my project and let you know how it turns out.