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.
This code is below the combobox object;
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?
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.
This code is below the combobox object;
VBA Code:
Private Sub cbo2_DropButtonClick()
Call AutoSizeDropDown(Me.cbo2, True)
End SubThe 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
)
