' call with
'
'Dim x As Boolean
'
'x = AutosizeCombo(Combo1)
Option Explicit
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const DT_CALCRECT = &H400
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SendMessageLong Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lparam 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
Public Function AutosizeCombo(Combo As ComboBox) As Boolean
'Automatically sizes a combo box to
'hold the longest item within it
Dim lngRet As Long
Dim lngCurrentWidth As Single
Dim rectCboText As RECT
Dim lngParentHDC As Long
Dim lngListCount As Long
Dim lngCounter As Long
Dim lngTempWidth As Long
Dim lngWidth As Long
Dim strSavedFont As String
Dim sngSavedSize As Single
Dim blnSavedBold As Boolean
Dim blnSavedItalic As Boolean
Dim blnSavedUnderline As Boolean
Dim blnFontSaved As Boolean
On Error GoTo ErrorHandler
'Grab the combo handle and list count
lngParentHDC = Combo.Parent.hdc
lngListCount = Combo.ListCount
If lngParentHDC = 0 Or lngListCount = 0 Then Exit Function
'Save combo box fonts, etc. to the parent
'object (form), for testing lengths with the API
With Combo.Parent
strSavedFont = .FontName
sngSavedSize = .FontSize
blnSavedBold = .FontBold
blnSavedItalic = .FontItalic
blnSavedUnderline = .FontUnderline
.FontName = Combo.FontName
.FontSize = Combo.FontSize
.FontBold = Combo.FontBold
.FontItalic = Combo.FontItalic
.FontUnderline = Combo.FontItalic
End With
blnFontSaved = True
'Get the width of the widest item
For lngCounter = 0 To lngListCount
DrawText lngParentHDC, Combo.List(lngCounter), -1, rectCboText, _
DT_CALCRECT
'Add twenty to the the number as a margin
lngTempWidth = rectCboText.Right - rectCboText.Left + 20
If (lngTempWidth > lngWidth) Then
lngWidth = lngTempWidth
End If
Next
'Get current width of combo
lngCurrentWidth = SendMessageLong(Combo.hwnd, CB_GETDROPPEDWIDTH, _
0, 0)
'If big enough then that's all A-OK
If lngCurrentWidth > lngWidth Then
AutosizeCombo = True
GoTo ErrorHandler
Exit Function
End If
'... but if not big enough, first calculate
'the screen width to ensure we don't exceed it!
If lngWidth > Screen.Width \ Screen.TwipsPerPixelX - 20 Then _
lngWidth = Screen.Width \ Screen.TwipsPerPixelX - 20
'Set the width of our combo
lngRet = SendMessageLong(Combo.hwnd, CB_SETDROPPEDWIDTH, lngWidth, 0)
'Set the function to True/False depending on API success
AutosizeCombo = lngRet > 0
ErrorHandler:
'If anything goes wrong, revert back!
On Error Resume Next
If blnFontSaved Then
With Combo.Parent
.FontName = strSavedFont
.FontSize = sngSavedSize
.FontUnderline = blnSavedUnderline
.FontBold = blnSavedBold
.FontItalic = blnSavedItalic
End With
End If
End Function
Reply With Quote
