Cool Custom Tooltips for ComboBoxes !

Thanks Thanks:  0
Likes Likes:  0
Page 1 of 2 12 LastLast
Results 1 to 10 of 15

Thread: Cool Custom Tooltips for ComboBoxes !

  1. #1
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Cool Custom Tooltips for ComboBoxes !

     
    Hi all,

    I was intrigued by the question posted here http://www.mrexcel.com/forum/showthread.php?t=295844 and after some experimentation i realised that it's not actually as easy as it first appears to show a tooltip window for each item of a DropDown as you hover over the items with the mouse.

    even moving and toggling the visible Property at run time of a lbl and/or a textbox and use them to mimic a tooltip didn't help as the latters get overlapped by the dropdown.

    Maybe i am just complicating things and am missing an easier solution/workaround !

    Anyway here is a workbook example : http://www.savefile.com/files/1303707


    and here is the code for future reference:


    This Code goes in the UserForm Module:

    Code:
     
    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_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_DropButt*******()
     
        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 Byte
     
        '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 Byte)
     
        sMessageString = sMessageString & CStr(row + 1) & vbTab
     
    End Sub
    this code goes in a Standard Module:

    Code:
     
    Option Explicit
     
    '****variables used in the UserForm module***
    Public hWndStatic As Long
    Public hWndDropDown As Long
    Public lRow As Long
    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()
     
        Const Width = 300 ' change these consts as required
        Const Height = 25
     
        With GetCursorPosition
            hWndStatic = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
            vbNullString, SS_CENTER + WS_CHILD, .x, .y, Width, _
            Height, 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
        Const WidthFactor = 30
        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
    Tried in XL2003 French version.

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  2. #2
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Just discovered that a compile error happens when the userform is moved about. To correct this, the Userform code should be as follow :

    Code:
     
    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_DropButt*******()
     
        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
    here is the updated workbook example: http://www.savefile.com/files/1304879

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  3. #3
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Great, Jafaar!!!
    Hall of Fame
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

  4. #4
    Board Regular
    Join Date
    Jul 2007
    Posts
    62
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    cool, didnt thing this was even a remote possiblility.

    i think i could use that

    fantastic

  5. #5
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Thanks guys for the feedback. much appreciated.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  6. #6
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    deleted
    Last edited by Jaafar Tribak; Jan 9th, 2008 at 03:19 AM.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  7. #7
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Hello again,

    Updated workbook example : http://www.savefile.com/files/1307464

    For the sake of completness,I have changed the overall layout of the code and the reason is that the ToolTip control code resided within the UserForm and that is not a good idea because it clatters up the userform module and the tooltip code can easily interfere with any other unrelated , existing code in the userform.


    So, a better approach is to encapsulate the ToolTip code in a Class module and leave the userform module empty.


    Another bonus of using a Class ToolTip is the facility with which one now can call and set the attributes of the tooltip.- You just create an instance of the ToolTip Class and plug it into the Combobox !


    so assuming the userform contains ComboBox1 with 12 items in it, here is how to attach the ToolTip to the combobox:


    In a Standard Module.

    Code:
     
    Option Explicit
    
    Private oToolTip  As ToolTip
    
    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
     
    

    Here is the code for the ToolTip Class Module :

    Code:
     
    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_DropButt*******()
        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
    and finally, here is the main code in a Standard Module :

    Code:
     
    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
    Regards.
    Last edited by Jaafar Tribak; Jan 9th, 2008 at 03:40 AM.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  8. #8
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Hi, Jafaar,

    Thank you for the update.
    The tooltip is empty when you stop moving the mouse just between two items. Of course not a real problem, but I think you like the challenge

    First I thought it was within the "Select Case Msg ... End Select", but some experiments showed me that this is not the reason...

    best regards,
    Erik
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

  9. #9
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

    Quote Originally Posted by erik.van.geit View Post
    Hi, Jafaar,

    Thank you for the update.
    The tooltip is empty when you stop moving the mouse just between two items. Of course not a real problem, but I think you like the challenge

    First I thought it was within the "Select Case Msg ... End Select", but some experiments showed me that this is not the reason...

    best regards,
    Erik
    Yes. I had noticed that. I brievely went trough the code to see why the tooltip doesn't redraw itself at the row borders but couldn't find the reason. I checked all the variables and they are all updated as they should. weird !

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  10. #10
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Cool Custom Tooltips for ComboBoxes !

      
    Thanks! Now I feel better that even the author didn't find a solution yet
    Still Hall Of Fame Worthy to my sense!!
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

 
DMCA.com