Adjust the Width of ComboBox Dropdown According to the Widest Entry

[Jaafar Tribak]

This is a common request but It is rather difficult to calculate the exact width of the text on the screen as computing the text size is greatly affected by the font type and the current screen zoom.

The following is as accurate and as generic as I could get it (code caters for different fonts and zooms) ...The code uses a few gdi32 API calls and a helper userform behind the scenes (UserForm is empty except for a single dummy combobox ).

Workbook Demo









1- Main API 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

Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName  As String * 32
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) 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 MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) 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 MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If


Dim uf As Object


Property Let EnableDropdownAutoSize _
    ( _
        ByVal ComboBox As MSForms.ComboBox, _
        Optional ByVal SelectLongestEntry As Boolean = False, _
        ByVal EnableAutoSize As Boolean _
    )
  
    If EnableAutoSize Then
        Call Resize(ComboBox, SelectLongestEntry)
    Else
        ComboBox.ShapeRange.AlternativeText = ""
        ComboBox.ListWidth = 0
    End If

End Property


Private Sub Resize(ByVal ComboBox As MSForms.ComboBox, Optional ByVal SelectLongestEntry As Boolean = False)

    #If VBA7 Then
        Dim hMemDC As LongPtr, hFont As LongPtr
    #Else
        Dim hMemDC As Long, hFont As Long
    #End If
  
    Const POINTSPERINCH As Long = 72
    Const LOGPIXELSY As Long = 90
    Const MM_TEXT = 1
    Const DT_CALCRECT = &H400
    Const SM_CXVSCROLL = 2
  
    Dim sz As Size, tTextRect As RECT, tFont As LOGFONT
    Dim lIndex As Long, lWidth As Long
    Dim lzoomAllowance As Long, lVerticalScrollBarWidth As Long
    Dim sWidestEntryText As String, lWidestEntryIndex As Long
  
  
    On Error GoTo Xit
  
    With ComboBox
        If .ShapeRange.AlternativeText = "" Then
            .ShapeRange.AlternativeText = "AutoSizeEnabled"
        Else
            .ShapeRange.AlternativeText = ""
            .ListWidth = 0
            Unload UF_Helper
            Exit Sub
        End If
    End With
  
    hMemDC = CreateCompatibleDC(0)
    Call SetMapMode(hMemDC, MM_TEXT)
  
    With tFont
        .lfFaceName = ComboBox.Font.Name & Chr(0)
        .lfHeight = -MulDiv(ComboBox.Font.Size, GetDeviceCaps(hMemDC, LOGPIXELSY), POINTSPERINCH)
        .lfWeight = ComboBox.Font.Bold
        .lfCharSet = ComboBox.Font.Charset
        .lfItalic = ComboBox.Font.Italic
        .lfStrikeOut = ComboBox.Font.Strikethrough
        .lfUnderline = ComboBox.Font.Underline
    End With
  
    hFont = CreateFontIndirect(tFont)
    Call SelectObject(hMemDC, hFont)
  
    With ComboBox
        For lIndex = 0 To .ListCount - 1
            Call GetTextExtentPoint32(hMemDC, .List(lIndex), Len(.List(lIndex)), sz)
            If sz.cx >= lWidth Then lWidth = sz.cx: sWidestEntryText = .List(lIndex):    lWidestEntryIndex = lIndex
            Call DrawText(hMemDC, .List(lIndex), -1, tTextRect, DT_CALCRECT)
        Next
    End With
  
    UF_Helper.Zoom = ActiveWindow.Zoom
    UF_Helper.HelperCombo.AutoSize = True
    UF_Helper.HelperCombo.Text = sWidestEntryText
  
    With UF_Helper.HelperCombo.Font
        .Name = ComboBox.Font.Name
        .Size = ComboBox.Font.Size
        .Bold = ComboBox.Font.Bold
        .Italic = ComboBox.Font.Italic
        .Weight = ComboBox.Font.Weight
        .Charset = ComboBox.Font.Charset
    End With
  
    With ComboBox
        lzoomAllowance = IIf(ActiveWindow.Zoom < 100, 60, 40) '<= you may have to adjust the (60,40) values to suit some Fonts.
        lVerticalScrollBarWidth = IIf(.LineCount >= .ListRows, PXtoPT(GetSystemMetrics(SM_CXVSCROLL), False, hMemDC), 0)
        If .Width - lzoomAllowance - lVerticalScrollBarWidth < lWidth Then
            .ListWidth = UF_Helper.HelperCombo.Width + lVerticalScrollBarWidth + lzoomAllowance
        End If
        If SelectLongestEntry Then
            .ListIndex = lWidestEntryIndex
        End If
    End With
  
Xit:
  
    Call DeleteObject(hFont)
    Call DeleteDC(hMemDC)
  
    If Err.Number Then
        ComboBox.ShapeRange.AlternativeText = ""
        ComboBox.ListWidth = 0
        Err.Raise Err.Number, , Err.Description
    End If

End Sub

#If VBA7 Then
    Private Function ScreenDPI(ByVal bVert As Boolean, ByVal MemDc As LongPtr) As Long
#Else
    Private Function ScreenDPI(ByVal bVert As Boolean, ByVal MemDc As Long) As Long
#End If
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hdc

    If lDPI(0) = 0 Then
        hdc = MemDc
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
    End If
    ScreenDPI = lDPI(Abs(bVert))

End Function


#If VBA7 Then
    Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean, ByVal MemDc As LongPtr) As Long
#Else
    Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean, ByVal MemDc As Long) As Long
#End If

    Const POINTSPERINCH As Long = 72
    PXtoPT = Pixels / (ScreenDPI(bVert, MemDc) / POINTSPERINCH)
  
End Function

2- Code Usage (in the Worksheet module):

Option Explicit

Private Sub ComboBox1_DropButtonClick()
    EnableDropdownAutoSize(ComboBox:=Sheet1.ComboBox1, SelectLongestEntry:=True) = True
End Sub

Private Sub ComboBox2_DropButtonClick()
    EnableDropdownAutoSize(ComboBox:=Sheet1.ComboBox2, SelectLongestEntry:=True) = True
End Sub

This is for embeeded comboboxes in worksheets... I believe, it should be easier to code and more likely to give more accurate results when applied to UserForm comboboxes.

 

[sijpie]

Jaafar, This is very useful, nice coding!

When I try to use it though, I get the error message that UF_Helper is not defined. Which object is this? Is this a hidden userform with a combobox called Helpercombo?

To get width of text in points I would normally put the text into a cell and then do autowidth and get the width of the column. That way you don't need to use API calls. (useable in Mac for instance). But since this code uses a lot of API calls one extra doesn't matter...

 

[Jaafar Tribak]

When I try to use it though, I get the error message that UF_Helper is not defined. Which object is this? Is this a hidden userform with a combobox called Helpercombo?

Yes, as mentioned in my post, the code makes use of a helper userform with a dummy combobox in it.

Before you run the code, you need to add a userform with an empty combobox in it.

Give the UserForm the name of UF_Helper and the combbox the name of HelperCombo .