Autosize combobox object suddenly crashes Excel

Bandito1

Board Regular
Joined
Oct 18, 2018
Messages
239
Office Version
  1. 2016
Platform
  1. Windows
Hi all,


I use code to autosize the dropdownlist that comes from the combobox cbo2.
It resizes to the max lenght of the value that is in it when I press the drop down button and rezises back to it's normal size when the drop menu is closed.

I used this code for a while now but it suddenly doesn't work anymore.
It gives some error that is unknown for me;
When i press 'OK" excel closes and restarts as repaired and i can't save it other then version 2.


Run Time Error.PNG


This code is below the combobox object;

VBA Code:
Private Sub cbo2_DropButtonClick()
     Call AutoSizeDropDown(Me.cbo2, True)
End Sub

The following code is all in a module called Module2
I got the code from internet so i have a hard time understanding it.
As said it worked perfectly before but it suddenly stopped working.

Someone knows what is going wrong?

VBA Code:
ption 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
VBA Code:
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
VBA Code:
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
VBA Code:
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
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
It was working yes

Well it's running on a company pc and i don't know when they update anything.
So that's may causing this issue?
 
Upvote 0
Yes, the workbook is working fine.
Lots of code in it but only this one crashes the whole excel.

Disabling it makes workable but now the combobox are hard to read cause the text in it is to long (that's why i had this code :) )
 
Upvote 0
if it is not absolutely necessary to use a combobox, you can instead load the combobox' list in a listbox on a separate userform with a textbox to filter it.
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top