Cool Custom Tooltips for ComboBoxes !

Option Explicit
 
Private Sub UserForm_Initialize()
 
    Dim i As Byte
 
    'poulate cmb and assign it to a global var
    With ComboBox1
        For i = 1 To 12
            .AddItem i
        Next
        .ListIndex = 0
    End With
    Set oCmb = Me.ComboBox1
 
    Call CreateStaticCtl
    Call SubClassStaticCtl
End Sub
 
Private Sub UserForm_Layout()
 
    hWndDropDown = 0
 
End Sub
 
Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 
    Call ShowWnd(hWndStatic, 0)
 
End Sub
 
Private Sub UserForm_Terminate()
 
    Call DestroyStaticCtl
 
End Sub
 
Private Sub ComboBox1_Change()
 
    Call SethWndDropDownTimerToZero
 
End Sub
 
Private Sub ComboBox1_DropButtonClick()
 
    hWndDropDown = GetWndUnderMouse
 
End Sub
 
Private Sub ComboBox1_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 
    Dim i As Long
 
    'store the y mouse coordinate in a global var
    CmbYpointer = y
 
    'don't show tooltip if mouse outside the dropdown
    If GetWndUnderMouse = hWndDropDown Or hWndDropDown = 0 _
    Then _
    Call ShowWnd(hWndStatic, 0): Exit Sub
 
 
   'otherwise show the tooltip
    Call ShowWnd(hWndStatic, 1)
 
 
    lStringLenght = Len(sMessageString)
 
    'compute the lStringLenght here so it
   'can be used to determine the width of
   'the tooltip dinamically in the "SetStaticPos" proc
    
    lStringLenght = (lStringLenght \ 30) + 1
    If lStringLenght = 0 Then lStringLenght = 1
    With GetCursorPosition
        Call SetStaticPos(hWndStatic, .x, .y)
    End With
 
    sMessageString = "This is some text for row # :  "
 
    Call ShowText(lRow)
 
    If lRow = 1 Then
        sMessageString = "This is some text for row # :  "
        sMessageString = sMessageString & CStr(lRow + 1) & vbTab
        sMessageString = sMessageString & String(45, "-")
        sMessageString = sMessageString & "This is some more text "
        sMessageString = sMessageString & "to demonstrate that the height of "
        sMessageString = sMessageString & "the tooltip control can also adjust "
        sMessageString = sMessageString & "itself automatically to accomodate "
        sMessageString = sMessageString & "all the text . "
    End If
 
End Sub
 
Private Sub ShowText(ByVal row As Long)
 
    sMessageString = sMessageString & CStr(row + 1) & vbTab
 
End Sub

<o:p>Option Explicit</o:p>
<o:p></o:p>
<o:p>Private oToolTip  As ToolTip</o:p>
<o:p>
Sub AttachToolTipToCombo()
 
    Const lRowsNumber As Long = 12 '==>this Const should match the
    Dim i             As Long      '# of rows of the combobox !! !
    Dim sToolTipText  As String
    Dim sTextArray(lRowsNumber) As String
 
    '********************************************
   'first, let's start the setup work for the tooltip text
 
    sToolTipText = "This is some more text for row #: "
 
    'set the text for each combobox row
  'and add them to a string array
    For i = 1 To lRowsNumber
        sTextArray(i) = sToolTipText & i
    Next i
 
    'handle the unique text for row # 2
    sToolTipText = sToolTipText & CStr(2) & vbTab
    sToolTipText = sToolTipText & String(52, "-")
    sToolTipText = sToolTipText & "This is some more text "
    sToolTipText = sToolTipText & "to demonstrate that the height of "
    sToolTipText = sToolTipText & "the tooltip control can also adjust "
    sToolTipText = sToolTipText & "itself automatically to accomodate "
    sToolTipText = sToolTipText & "all the text . "
 
    sTextArray(2) = sToolTipText
 
    'done with the setup work
  '********************************************
 
    'ok, we are now done with the setup work
  'so, let's create a new ToolTip instance now
    Set oToolTip = New ToolTip
 
    'plug the tooltip into the combo & set its attributes
    With oToolTip
        .CreateToolTip Form:=UserForm1, ComboBox:=UserForm1.ComboBox1, _
        ComboRows:=lRowsNumber, TextArray:=sTextArray(), ToolTipWidth:=35
    End With
 
    'display the userform that contains the combobox
    UserForm1.Show
 
    'important to avoid crashing XL !!!!
    Set oToolTip = Nothing
 
End Sub
 
</o:p>

Option Explicit
 
Private WithEvents Frm_events As UserForm
Private WithEvents Cmb_events As ComboBox
 
Private arTemp() As String
Private Sub Class_Terminate()
 
    Call DestroyStaticCtl
 
End Sub
 
Private Sub Cmb_events_Change()
    Call SethWndDropDownTimerToZero
End Sub
 
Private Sub Cmb_events_DropButtonClick()
    hWndDropDown = GetWndUnderMouse
End Sub
 
Private Sub Cmb_events_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 
    Dim i        As Long
 
    'store the y mouse coordinate in a global var
    CmbYpointer = Y
 
    'don't show tooltip if mouse outside the dropdown
    If GetWndUnderMouse = hWndDropDown Or hWndDropDown = 0 _
    Then _
    Call ShowWnd(hWndStatic, 0): Exit Sub
 
   'otherwise show the tooltip
    Call ShowWnd(hWndStatic, 1)
 
    lStringLenght = Len(sMessageString)
 
    'compute the lStringLenght here so it
  'can be used to determine the width of
  'the tooltip dinamically in the "SetStaticPos" proc
 
    lStringLenght = (lStringLenght \ 30) + 1
    If lStringLenght = 0 Then lStringLenght = 1
    With GetCursorPosition
        Call SetStaticPos(hWndStatic, .X, .Y)
    End With
 
    Call ShowText(lRow)
 
End Sub
 
Private Sub Frm_events_Layout()
    hWndDropDown = 0
End Sub
 
Private Sub Frm_events_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call ShowWnd(hWndStatic, 0)
End Sub
 
Private Sub ShowText(ByVal row As Long)
    sMessageString = arTemp(CStr(row + 1))
End Sub
 
Public Sub CreateToolTip _
(Form As UserForm, ComboBox As ComboBox, TextArray() As String, _
 ComboRows As Long, ToolTipWidth As Double)
 
    'store the params in module level variables
    arTemp() = TextArray()
    WidthFactor = ToolTipWidth
    Set Frm_events = Form
    Set Cmb_events = ComboBox
 
    'hook the combobox here
    Set oCmb = Cmb_events
 
    'create the tooltip ctl here and subclass it
    Call CreateStaticCtl
    Call SubClassStaticCtl
 
End Sub

Option Explicit
 
'****variables used in the UserForm module***
Public hWndStatic As Long
Public hWndDropDown As Long
Public lRow As Long
Public WidthFactor As Double
Public CmbYpointer As Double
Public lStringLenght As Long
Public sMessageString As String
Public oCmb As ComboBox
'*********************************************
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
 
Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
  Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
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 dFontHeight, dFontWidth As Double
 
Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
 
Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
 
Private lTimerID As Long
 
Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
 
Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nBkMode As Long) As Long
 
 Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
 
Declare Function DrawEdge Lib "user32" _
(ByVal hdc As Long, qrc As RECT, ByVal edge As Long, _
ByVal grfFlags 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)
 
 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 Const DT_LEFT = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_NOCLIP = &H100
 
 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
 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 Const GWL_WNDPROC = (-4)
Private Const WM_MOVE = &H3
Private lPrevWnd As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
 
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 hdc As Long
 
Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Declare Function FillRect Lib "User32.dll" (ByVal hdc As Long, _
ByRef lpRect As RECT, ByVal hBrush As Long) As Long
 
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
 
Declare Function BeginPaint Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
 
Declare Function EndPaint Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Const RDW_INTERNALPAINT = &H2
Private Const WM_ACTIVATE = &H6
Private Const WM_PAINT = &HF
Private Const WM_DESTROY = &H2
 
Declare Function RedrawWindow Lib "user32" _
(ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
 
Private Const RDW_ERASE = &H4
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ERASENOW = &H200
 
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 
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
 
Declare Function GetClientRect Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpRect As RECT) As Long
 
Private uClientArea As RECT
 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
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 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 COLORR = 14811135 ' tooltipcolor
 
Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
 
Declare Function GetDesktopWindow Lib "user32" () As Long
 
Declare Function DestroyWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long
 
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
 
  'store the static cntl dc
    hdc = GetDC(hWnd)
 
    'store the static ctl area to be painted
    GetClientRect hWnd, uClientArea
 
    'catch the paint and move msgs
    Select Case Msg
 
    Case WM_PAINT
        With uClientArea
            'paint the static ctl and draw a frame on it
            Call DrawRect _
            (hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, 14811135)
            DrawEdge hdc, uClientArea, EDGE_ETCHED, BF_RECT
        End With
    Case WM_MOVE
       'create a new font for the static ctl text
        With uFont
            .lfFaceName = "Arial" & Chr$(0)
            .lfHeight = 16 ' change these font params as required
            .lfWidth = 6 '
            'store the width and height in public vars
          'so they can be used to set the dims of the static
           'ctl in the userform module
            dFontHeight = .lfHeight
            dFontWidth = .lfWidth
        End With
        lFHwnd = CreateFontIndirect(uFont)
        lOldFont = SelectObject(hdc, lFHwnd)
        SetBkMode hdc, 1
 
        'redraw the static ctl each time a new row of the
      'combobox ia highlighted by the mouse pointer
        If lRow <> Int(CmbYpointer / (8 + 1.75)) + oCmb.TopIndex Then
            lRow = Int(CmbYpointer / (8 + 1.75)) + oCmb.TopIndex
            RedrawWindow _
            hWnd, ByVal 0&, ByVal 0&, RDW_ERASE + RDW_INVALIDATE
        End If
        DrawEdge hdc, uClientArea, EDGE_ETCHED, BF_RECT
 
        'draw the text for each highlighted cmb row
        DrawText _
        hdc, sMessageString, Len(sMessageString), uClientArea, _
        DT_NOCLIP + DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK
 
    Case WM_DESTROY
        'Remove the wnd Subclassing
        Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevWnd)
 
        End Select
 
    'cleanup to avoid memory leaks!
    SelectObject hdc, lOldFont
    DeleteObject lFHwnd
    ReleaseDC hWnd, hdc
 
    CallBack = CallWindowProc(lPrevWnd, hWnd, Msg, wParam, ByVal lParam)
 
End Function
 
Private Sub DrawRect _
(lhwnd As Long, Left, Top, width, Height, color)
 
    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
    lDc = GetDC(lhwnd)
    tLB.lbColor = color
   'Create a new brush
    hBrush = CreateBrushIndirect(tLB)
    SetRect tR, Left, Top, width, Height
    'Fill the form with our brush
    FillRect lDc, tR, hBrush
    Call DeleteObject(hBrush)
    RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
    DeleteDC lDc
    Call EndPaint(lhwnd, tPS)
 
End Sub
 
Sub CreateStaticCtl()
 
    With GetCursorPosition
        hWndStatic = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
        vbNullString, SS_CENTER + WS_CHILD, .X, .Y, 0, _
        0, GetDesktopWindow, 0, 0, 0)
    End With
End Sub
 
Sub SubClassStaticCtl()
    lPrevWnd = SetWindowLong(hWndStatic, GWL_WNDPROC, AddressOf CallBack)
End Sub
 
Function GetCursorPosition() As POINTAPI
    Dim tP As POINTAPI
 
    GetCursorPos tP
    GetCursorPosition = tP
End Function
 
Function GetWndUnderMouse() As Long
    Dim tP As POINTAPI
 
    GetCursorPos tP
    GetWndUnderMouse = WindowFromPoint(tP.X, tP.Y)
End Function
 
Sub ShowWnd(hWnd As Long, Visible As Long)
    ShowWindow hWnd, Visible
End Sub
 
Sub SetStaticPos _
(hWnd As Long, Left As Long, Top As Long)
 
    'change thse constantes to suit
    Const OffsetX = 30
    Const OffsetY = 10
    SetWindowPos hWnd, 0, Left + OffsetX, Top + OffsetY, _
    dFontWidth * WidthFactor, dFontHeight * lStringLenght, 0
End Sub
 
Sub DestroyStaticCtl()
    DestroyWindow hWndStatic
End Sub
 
Function GetDropDownhWnd() As Long
    Dim tP As POINTAPI
 
    GetCursorPos tP
    GetDropDownhWnd = WindowFromPoint(tP.X, tP.Y)
End Function
 
Sub SethWndDropDownTimerToZero()
    lTimerID = SetTimer(0, 0, 1, AddressOf TimerCallback)
End Sub
 
Private Sub TimerCallback()
    KillTimer 0, lTimerID
    hWndDropDown = 0
End Sub