Tooltips for a listbox

D

dcanham

Active Member
Joined
Jun 7, 2006
Messages
306
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.
 
Sort by date Sort by votes
Code is correct this time still, but still being let down by ItemUnderMouse
Any ideas anyone on this?

VBA Code: 
'http://www.vb-helper.com/howto_listbox_item_tooltips.html
Private Type POINTAPI
    X As LongPtr
    Y As LongPtr
End Type

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

'https://www.excelbanter.com/excel-programming/396436-how-get-screen-resolution-vba.html
Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Function ClientToScreen Lib "User32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As LongPtr
Private Declare PtrSafe Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As LongPtr, ByVal ptX As LongPtr, ByVal ptY As LongPtr, ByVal bAutoScroll As LongPtr) As LongPtr

Private m_TooltipText() As String
Public Function ScreenHeight() As LongPtr
ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Function

Public Function ScreenWidth() As LongPtr
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function
Private Sub UserForm_Initialize()

'Load Example Listbox
With ListBox1

For Each Item In Array("Select an item", "Apple fritters", "Banana pie", "Cherriers jubilee", Date, "Ribbet", "", "Sorry, no help for you!")
.AddItem Item
Next


ReDim m_TooltipText(-1 To ListBox1.ListCount - 1)
m_TooltipText(-1) = "Select an item"
m_TooltipText(0) = "Apple fritters"
m_TooltipText(1) = "Banana pie"
m_TooltipText(2) = "Cherriers jubilee"
m_TooltipText(3) = Date
m_TooltipText(4) = "Ribbet"
m_TooltipText(5) = ""
m_TooltipText(6) = "Sorry, no help for you!"

End With

End Sub
' See which item is under the mouse and display its tooltip.
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ListBox1.ControlTipText = m_TooltipText(ItemUnderMouse(ListBox1.[_GethWnd], X, Y))
End Sub
' Return the index of the item under the mouse.
Public Function ItemUnderMouse(ByVal list_hWnd As LongPtr, ByVal X As Single, ByVal Y As Single)

Dim pt As POINTAPI

    pt.X = X \ ScreenWidth  'Screen.TwipsPerPixelX - not part of native VBA
    pt.Y = Y \ ScreenHeight  'Screen.TwipsPerPixelY  - not part of native VBA

    ClientToScreen list_hWnd, pt
    ItemUnderMouse = LBItemFromPt(list_hWnd, pt.X, pt.Y, False)
    
End Function
 
Upvote 0

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
@Handyman84

That code is for vb6 . I don't think the LBItemFromPt api will work on MsForms controls.

I have adapted and made a few additions to this vb6 code (Credit for the original code kindly goes to Elroy)

Workbook Example:
ListBoxItemsToolTip.xlsm







1-In a Standard Module:
VBA Code: 
Option Explicit

Public Enum ttIconType
    TTNoIcon = 0
    TTIconInfo = 1
    TTIconWarning = 2
    TTIconError = 3
End Enum

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
   #If Win64 Then
        hwnd      As LongLong
        uId       As LongLong
        cRect     As RECT
        hinst     As LongLong
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As RECT
        hinst     As Long
   #End If
   lpszText  As String
End Type

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe 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 LongPtr, ByVal hMenu As Long, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If


#If Win64 Then
    Public Sub CreateToolTip(ByVal ParentHwnd As LongLong, _
        ByVal TipText As String, _
        Optional ByVal uIcon As ttIconType = TTNoIcon, _
        Optional ByVal sTitle As String, _
        Optional ByVal lForeColor As Long = -1, _
        Optional ByVal lBackColor As Long = -1, _
        Optional ByVal bCentered As Boolean, _
        Optional ByVal bBalloon As Boolean, _
        Optional ByVal lWrapTextLength As Long = 50, _
        Optional ByVal lDelayTime As Long = 200, _
        Optional ByVal lVisibleTime As Long = 5000)
#Else
    Public Sub CreateToolTip(ByVal ParentHwnd As Long, _
        ByVal TipText As String, _
        Optional ByVal uIcon As ttIconType = TTNoIcon, _
        Optional ByVal sTitle As String, _
        Optional ByVal lForeColor As Long = -1, _
        Optional ByVal lBackColor As Long = -1, _
        Optional ByVal bCentered As Boolean, _
        Optional ByVal bBalloon As Boolean, _
        Optional ByVal lWrapTextLength As Long = 50, _
        Optional ByVal lDelayTime As Long = 200, _
        Optional ByVal lVisibleTime As Long = 5000)
#End If
  
        ' If lWrapTextLength = 0 then there will be no wrap.
        ' Also, lWrapTextLength = 40 is a minimum value.
        ' The max for lVisibleTime is 32767.
                          
        Const TOOLTIPS_CLASSA = "tooltips_class32"
        Const ICC_WIN95_CLASSES = &HFF
        Const CW_USEDEFAULT = &H80000000
        Const WM_USER = &H400
        Const TTM_ACTIVATE = WM_USER + 1
        Const TTM_ADDTOOLA = WM_USER + 4
        Const TTM_SETDELAYTIME = WM_USER + 3
        Const TTM_UPDATETIPTEXTA = WM_USER + 12
        Const TTM_SETTIPBKCOLOR = WM_USER + 19
        Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
        Const TTM_SETMAXTIPWIDTH = WM_USER + 24
        Const TTM_SETTITLE = WM_USER + 32
        Const TTS_NOPREFIX = &H2
        Const TTS_BALLOON = &H40
        Const TTS_ALWAYSTIP = &H1
        Const TTF_CENTERTIP = &H2
        Const TTF_IDISHWND = &H1
        Const TTF_SUBCLASS = &H10
        Const TTF_TRANSPARENT = &H100
        Const TTDT_AUTOPOP = 2
        Const TTDT_INITIAL = 3
      
        #If Win64 Then
            Dim hwndTT As LongLong
        #Else
            Dim hwndTT As Long
        #End If
      
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long, lRealColor As Long
        Dim ti As TOOLINFO
        Dim tIccex As InitCommonControlsEx
  
  
        If Not bCommonControlsInitialized Then
            With tIccex
                .Size = LenB(tIccex)
                .ICC = ICC_WIN95_CLASSES
            End With
            If InitCommonControlsEx(tIccex) = False Then
                Call InitCommonControls
            End If
            bCommonControlsInitialized = True
        End If
    
        ' Destroy any previous tooltip.
        Call DestroyWindow(FindWindow(TOOLTIPS_CLASSA, "MyToolTip"))
      
        ' Format the text.
        FormatTooltipText TipText, lWrapTextLength
      
        ' Initial style settings.
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If bBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON ' Create baloon style if desired.
      
        ' Set the style.
        hwndTT = CreateWindowEx(0&, TOOLTIPS_CLASSA, "MyToolTip", lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, _
            CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, GetModuleHandle(vbNullString), 0&)
      
        ' Setup our tooltip info structure.
        With ti
            .uFlags = TTF_SUBCLASS Or TTF_IDISHWND
            If bCentered Then .uFlags = .uFlags Or TTF_CENTERTIP
            ' Set the hwnd prop to our parent control's hwnd.
            .hwnd = ParentHwnd
            .uId = ParentHwnd
            .hinst = GetModuleHandle(vbNullString)
            .lpszText = TipText
            .cbSize = LenB(ti)
        End With
      
    '   Debug.Print SendMessage(hwndTT, TTM_SETMAXTIPWIDTH, 0&, 100)
        SendMessage hwndTT, TTM_ADDTOOLA, 0&, ti
        SendMessage hwndTT, TTM_UPDATETIPTEXTA, 0&, ti
      
        ' Colors.
        If lForeColor <> -1 Then SendMessage hwndTT, TTM_SETTIPTEXTCOLOR, lForeColor, 0&
        If lBackColor <> -1 Then
            Call TranslateColor(lBackColor, 0, lRealColor)
            SendMessage hwndTT, TTM_SETTIPBKCOLOR, lRealColor, 0&
        End If
      
        ' Title or icon.
        If uIcon <> TTNoIcon Or sTitle <> vbNullString Then SendMessage hwndTT, TTM_SETTITLE, CLng(uIcon), ByVal sTitle
      
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lVisibleTime
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_INITIAL, lDelayTime
End Sub

Public Sub DestroyToolTip()
    ' It's not a bad idea to put this in the Form_Unload event just to make sure.
    Const TOOLTIPS_CLASSA = "tooltips_class32"
    Call DestroyWindow(FindWindow(TOOLTIPS_CLASSA, "MyToolTip"))
End Sub

Private Sub FormatTooltipText(TipText As String, lLen As Long)
    Dim s As String
    Dim i As Long
    '
    ' Make sure we need to do anything.
    If lLen = 0 Then Exit Sub
    If lLen < 40 Then lLen = 40
    If Len(TipText) <= lLen Then Exit Sub
    '
    Do
        i = InStrRev(TipText, " ", lLen + 1)
        If i = 0 Then
            s = s & Left$(TipText, lLen) & vbCrLf ' Build "s" and trim from TipText.
            TipText = Mid$(TipText, lLen + 1)
        Else
            s = s & Left$(TipText, i - 1) & vbCrLf ' Build "s" and trim from TipText.
            TipText = Mid$(TipText, i + 1)
        End If
        If Len(TipText) <= lLen Then
            TipText = s & TipText ' Place "s" back into TipText and get out.
            Exit Sub
        End If
    Loop
End Sub


2- Usage Example in the UserForm Module:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If


Private Sub UserForm_Initialize()
    Dim i As Long
    For i = 1 To 100
        ListBox1.AddItem "[" & i & "] :   " & RandomString(50)
        ListBox2.AddItem "[" & i & "] :   " & RandomString(500)
        ListBox3.AddItem "[" & i & "] :   " & RandomString(30)
    Next i
End Sub

Private Sub UserForm_Terminate()
    Call DestroyToolTip
End Sub


Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Call AddToolTip(ListBox1)
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AddToolTip(ListBox2)
End Sub

Private Sub ListBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call AddToolTip(ListBox3)
End Sub

Private Sub AddToolTip(ByVal Lbx As Control)
    Static vPrevKid As Variant
    Dim tCurPos As POINTAPI, oAcc As IAccessible, vKid As Variant
  
    Call GetCursorPos(tCurPos)
    Set oAcc = Lbx
    vKid = oAcc.accHitTest(tCurPos.X, tCurPos.Y)
    If Lbx.[_GethWnd] = 0 Then Lbx.SetFocus
        If vPrevKid <> vKid And vKid > 0 Then
            Select Case True
                Case Lbx Is ListBox1
                    CreateToolTip Lbx.[_GethWnd], Lbx.List(vKid - 1), , , , , , , 50, 0
                Case Lbx Is ListBox2
                    CreateToolTip Lbx.[_GethWnd], Lbx.List(vKid - 1), _
                                TTIconWarning, "Item" & CStr(vKid), vbYellow, vbBlack, , True, 50, 0
                Case Lbx Is ListBox3
                    CreateToolTip Lbx.[_GethWnd], Lbx.List(vKid - 1), _
                                TTIconInfo, "Item" & CStr(vKid), vbBlue, vbCyan, , True, , 0
            End Select
        End If
    vPrevKid = vKid
End Sub

Private Function RandomString(MaxLenght As Integer) As String
    Dim sCharset As String, lRndLenght As Long, i As Long
    sCharset = "ABCDEGHIJKLMNOPQRSTUVWXYZ0123456789"
  
    Call Randomize
    lRndLenght = Int(Rnd() * MaxLenght) + 1
    For i = 1 To lRndLenght
        RandomString = RandomString & Mid(sCharset, Int(Rnd() * Len(sCharset) + 1), 1)
    Next
End Function


EDIT: Adding individual tooltips to ComboBoxes is proving more difficult. The main reason being comboboxes don't have a hwnd. Maybe using MS Accessibility can help us find a workaround.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Z
  • Question
Creating a report/list from a count
Replies
0
Views
118
Zeke247
Z
sparky2205
  • Question
ListBox not highlighting selection
Replies
0
Views
133
sparky2205
sparky2205
B
  • Solved
Retrieve a single value from a MultiColumn ListBox
Replies
3
Views
341
Anthony47
A
M
  • Solved
Display textbox from listbox - getting 381 error
Replies
4
Views
374
maiatanaka
M
R
  • Question
Userform Bugginess
Replies
2
Views
112
RockandGrohl
R

Forum statistics

Threads
1,216,473
Messages
6,130,837
Members
449,597
Latest member
buikhanhsang

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top