Extending (width) combobox

[Bandito1]

Hi all,

I got values in my combobox that are to long to fit in the combobox.
The combobox (cboObservation) is on a userform.

I use the following to increase the width of the combobox so i can read the values in it;

Private Sub cboObservation1_DropButtonClick()
cboObservation1.Width = 200
End Sub

That works.

Now i would like to return the combobox to width 90 when i click a value in the combobox.

I tried with;

Private Sub cboObservation1_AfterUpdate()
cboObservation1.Width = 90
End Sub

But it only "fires" when i click in another textbox. I would like that it "fires" when i click a value.

The click event doesn't do the job..
Someone knows how i can improve the AfterUpdate or how to set width to 90 when i select an item?

When i open the combobox the width should go to 200. When i select an item it should return to 90.

 

[John_w]

Try this:

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    cboObservation1.Width = 90
End Sub

 

[Bandito1]

Well it works but it got some heavy delay. It's far from instant.
Not as fast as AfterUpdate and clicking in some other textbox

 

[Jaafar Tribak]

It is probably better to resize only the DropDown List portion of the ComboBox.

With this code, the dropdown list should resize itself automatically to accomodate the widest entry... Should work regardless of the applied zoom and regradless of the combobox Font size.

Here is an example:

Download:
ResizeComboBoxDropDownList.xlsm

1- Code in a Standard Module :

Option Explicit

#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 "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, 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 GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As LongPtr, ByVal lpsz As LongPtr, ByVal cbString As Long, lpSize As Size) 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 Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As LongPtr, ByVal lpsz As LongPtr, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

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


Public Function AutoSizeDropDown( _
    ByVal ComboBox As MSForms.ComboBox, _
    Optional ByVal JumpToWidestEntry As Boolean = False _
) As Long

    Const MM_TEXT = 1&
    Const SM_CXVSCROLL = 2&
 
    Static bDropDownState As Boolean
    Dim hMemDc As LongPtr
    Dim hPrevFont As LongPtr
    Dim IFont As stdole.IFont
    Dim lPrevMPMode As Long
    Dim lIndex As Long
    Dim lMaxWidth As Long
    Dim lMaxIndex As Long
    Dim sItemText As String
    Dim sWidestText As String
    Dim tSize As Size

    hMemDc = CreateCompatibleDC(NULL_PTR)
    If hMemDc Then
        lPrevMPMode = SetMapMode(hMemDc, MM_TEXT)
        Set IFont = ComboBox.Font
        hPrevFont = SelectObject(hMemDc, IFont.hFont)
        With ComboBox
            For lIndex = 0& To .ListCount - 1&
                sItemText = .List(lIndex)
                Call GetTextExtentPoint32(hMemDc, StrPtr(sItemText), Len(sItemText), tSize)
                If lMaxWidth < tSize.cx Then
                    lMaxWidth = tSize.cx
                    sWidestText = sItemText
                    lMaxIndex = lIndex
                End If
            Next lIndex
            'Debug.Print lMaxIndex, sWidestText
            AutoSizeDropDown = lMaxIndex
            lMaxWidth = PXtoPT(hMemDc, lMaxWidth + 2.5 * GetSystemMetrics(SM_CXVSCROLL), False)
            Call SetMapMode(hMemDc, lPrevMPMode)
            Call SelectObject(hMemDc, hPrevFont)
            Call DeleteDC(hMemDc)
            .ListWidth = lMaxWidth
            If JumpToWidestEntry Then
                If bDropDownState = False Then
                    .ListIndex = lMaxIndex
                End If
            End If
            bDropDownState = Not bDropDownState
        End With
    End If

End Function

Private Function ScreenDPI(ByVal bVert As Boolean, ByVal hDC As LongPtr) As Long
    Const LOGPIXELSX As Long = 88&
    Const LOGPIXELSY As Long = 90&
    Static lDPI(1&) As Long

    If lDPI(0&) = 0& Then
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PXtoPT(ByVal hDC As LongPtr, ByVal Pixels As Single, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72&
    PXtoPT = (Pixels / (ScreenDPI(bVert, hDC) / POINTSPERINCH))
End Function

2- Code Usage Example as per the workbook in the link above:

In the UserForm Module:

Option Explicit

Private Sub UserForm_Initialize()

    Dim i As Long
 
    With Cmbo_Zoom
        For i = 1 To 3&
            .AddItem CSng(i / 2&)
        Next i
        .ListIndex = 1&
    End With
 
    With Me.Cmbo_Font_Size
        For i = 4& To 40& Step 4&
            .AddItem i
        Next i
        .ListIndex = 1&
    End With
 
    With Me.Cmbo_Autosize
        For i = 1& To 100&
            .AddItem i - 1& & " - " & RandomString(40&)
        Next i
        .Value = .List(0&)
        .Font.Size = Me.Cmbo_Font_Size.List(1&)
    End With

End Sub

Private Sub Cmbo_Autosize_DropButtonClick()
    With Me.LblWidestEntry
        .Caption = "Index Of Widest Entry [zero-based Index]:  "
        .Caption = .Caption & AutoSizeDropDown(Me.Cmbo_Autosize, True)
    End With
End Sub

Private Sub Cmbo_Zoom_Change()
    Dim sTmp As String
    sTmp = Replace(Cmbo_Zoom.Text, ".", Application.DecimalSeparator)
    sTmp = Replace(sTmp, ",", Application.DecimalSeparator)
    Me.Zoom = 100& * sTmp
End Sub

Private Sub Cmbo_Font_Size_Change()
    Me.Cmbo_Autosize.Font.Size = Cmbo_Font_Size
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

 

[Bandito1]

Thanks for your reply
It's exactly what im looking for.

Tried to understand the code a bit and change it a bit but;

Private Sub Cmbo_Autosize_DropButtonClick()
    With Me.LblWidestEntry
        .Caption = "Index Of Widest Entry [zero-based Index]:  "
        .Caption = .Caption & AutoSizeDropDown(Me.Cmbo_Autosize, True)
    End With
End Sub

I can't get this to work without the label lblWidestEntry.

Is this label really needed?

Tried to look info up about AutoSizeDropDown but when i replace code with;

Private Sub Cmbo_Autosize_DropButtonClick()
Cmbo_Autosize.AutoSize = True
End Sub
[/CODE]

The code doesn't work anymore

 

[Jaafar Tribak]

Thanks for your reply
It's exactly what im looking for.
I can't get this to work without the label lblWidestEntry.
Is this label really needed?

You don't need any of those extra controls... Those extra controls were added just for demonstration purposes regarding various zooms and font sizes.

You would only need to use code in the UserForm Module as follows;

Assuming your combobox is ComboBox1

Option Explicit

Private Sub UserForm_Initialize()
    Dim i As Long
    With Me.ComboBox1
        For i = 1& To 100&
            .AddItem i - 1& & " - " & RandomString(40&)
        Next i
        .Value = .List(0&)
    End With

End Sub

Private Sub ComboBox1_Change()
    Call AutoSizeDropDown(Me.ComboBox1, True)
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

Here is a bare bone implementation example :
Bandito.xlsm

 

[Bandito1]

Thank you for your extensive explanation!

It works