Widening the Dropdown List of an activeX ComboBox to accomodate the longest entry

[Jaafar Tribak]

Hi dear forum members,

As the title says, I have written this code in order to allow the widening of comboboxes dropdowns without the need to make the actual combobox wider.

In order to get the most accurate results, the value of the Const : "TUNING_SCALE_CONSTANT" declared at the top of the 'API _bas' module may need to be adjusted according to the currrent Worksheet zoom, the combo Font Size etc ...

Try experimenting with that constant until you find the satisfactory value that works best for the current zoom, font size etc ..

BTW, I am referring here to ComboBoxes embedeed in worksheets not on UserForms.

Workbook example







1- Api based code in a Standard Module :

Option Explicit

Private Type Size
    cx As Long
    cy As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

     Private Type CWPSTRUCT
            lParam As LongPtr
            wParam As LongPtr
            message As Long
            hwnd As LongPtr
    End Type

    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    
    Private hHook As LongPtr, hPrevWndProc As LongPtr, hDropDownHwnd As LongPtr
     
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
     
    Private Type CWPSTRUCT
        lParam As Long
        wParam As Long
        message As Long
        hwnd As Long
    End Type

    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) 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 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 GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) 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
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    
    Private hHook As Long, hPrevWndProc As Long, hDropDownHwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const WH_CALLWNDPROC = 4
Private Const WM_CREATE = &H1
Private Const GWL_WNDPROC = (-4)
Private Const WM_PAINT = &HF
Private Const GWL_STYLE As Long = -16
Private Const SWP_NOMOVE = &H2
Private Const SWP_SHOWWINDOW = &H40

[B][COLOR=#008000]'==================================================[/COLOR][/B]
[B][COLOR=#008000]'    IMPORTANT !!                                                                        '[/COLOR][/B]
[B][COLOR=#008000]'==============                                                                         '[/COLOR][/B]
[B][COLOR=#008000]'    Experiment with the value of this Const value until you find'                    '[/COLOR][/B]
[B][COLOR=#008000]'    the satifactory value for the current zoom, Font size etc ...  '[/COLOR][/B]
    Private Const TUNING_SCALE_CONSTANT = 50
[B][COLOR=#008000]'==================================================[/COLOR][/B]

Private oCombo As Object
Private vArrList() As Variant


Public Sub AllowDropDownWidening(ByVal ComboBox As Object)

    Set oCombo = ComboBox
    vArrList() = Application.Transpose(ComboBox.List)
    
    If IsWindowVisible(hDropDownHwnd) Then Exit Sub
    
    Call UnhookWindowsHookEx(hHook)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookFunction, Application.HinstancePtr, GetWindowThreadProcessId(Application.hwnd, 0))
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookFunction, Application.Hinstance, GetWindowThreadProcessId(Application.hwnd, 0))
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Sub


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function HookFunction(ByVal ncode As Long, ByVal wParam As LongPtr, lParam As CWPSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function HookFunction(ByVal ncode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim strClass As String
    
    On Error Resume Next
    If lParam.message = WM_CREATE Then
        hDropDownHwnd = lParam.hwnd
        strClass = Space(255)
        strClass = Left(strClass, GetClassName(lParam.hwnd, ByVal strClass, 255))
        If InStr(1, strClass, "F3 Server") Then
            Call UnhookWindowsHookEx(hHook)
            hPrevWndProc = SetWindowLong(lParam.hwnd, GWL_WNDPROC, AddressOf SubClassFunction)
        End If
    End If
    HookFunction = CallNextHookEx(hHook, ncode, wParam, ByVal lParam)
    
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function SubClassFunction(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim lStyle As LongPtr, hdc As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function SubClassFunction(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lStyle As Long, hdc As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim tRect As RECT, tTextSize As Size
    Dim strClass As String * 256, lret As Long
    Dim lWidth As Long, i As Long
                 
    On Error Resume Next
    Select Case Msg
        Case WM_PAINT
            lret = GetClassName(hwnd, strClass, 256)
            lStyle = GetWindowLong(hwnd, GWL_STYLE)
            If lStyle = 1442840576 Then
                hdc = GetDC(0)
                GetWindowRect (hwnd), tRect
                For i = 1 To UBound(vArrList)
                    Call GetTextExtentPoint32(hdc, vArrList(i), Len(vArrList(i)), tTextSize)
                    If lWidth <= tTextSize.cx Then lWidth = tTextSize.cx
                Next i
                ReleaseDC 0, hdc
                lWidth = (lWidth + TUNING_SCALE_CONSTANT) * (ActiveWindow.Zoom / 100)
                If oCombo.Width < lWidth Then
                    SetWindowPos GetParent(hwnd), 0, 0, 0, lWidth, tRect.Bottom - tRect.Top, SWP_NOMOVE + SWP_SHOWWINDOW
                End If
                Call SetWindowLong(hwnd, GWL_WNDPROC, hPrevWndProc)
                Exit Function
            End If
    End Select
    SubClassFunction = CallWindowProc(hPrevWndProc, hwnd, Msg, wParam, ByVal lParam)
End Function

2- Code Usage in the Worksheet Module:

Option Explicit

Private Sub ComboBox1_DropButt*******()
    Call AllowDropDownWidening(Me.ComboBox1)
End Sub

Private Sub ComboBox2_DropButt*******()
    Call AllowDropDownWidening(Me.ComboBox2)
End Sub

I hope you will find this useful.

 

[gallen]

Can't you just set the 'Autosize' property to True at design time?

 

[Jaafar Tribak]

Can't you just set the 'Autosize' property to True at design time?

That would widen the actual ComboBox ... Here, I am just widening the dropdown list that comes up when clicking on the down-arrow button. This can sometimes be useful where there isn't much space on the worksheet.

In fact, I have seen this functionality requested many times by some users but the answer was "It coudn't be done".

Regards.

 

[gallen]

Ahh I see. I've never heard of that facility in the packaged Active X control.

If I wanted that I'd be expecting I'd have to create my own custom Active X control although I suspect there's already one out there somewhere.