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
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 Function AutosizeCombo(CB As ComboBox) As Boolean
'Automatically sizes a combo box to hold the longest item within it
'A substantial portion of this code was written by other people. I found
'the basis for this on one of the 'VB Source Code Web sites. Originally,
'this routine was passed a number and the routine resized the combo box
'to the width of the passed number, not to the size of its 'longest item width.
'In another routine, I found an example of useing the DrawText API and thought
'it would be a cool idea to combine the two into a routine which does what this does.
'The only truly original aspect of this routine is the feature that I built in to
'accommodate changes in font size and style (bold, italic, underline, name).
'The rest is an congolmoration of the two pieces of code already mentioned.
Dim LongReturn As Long
Dim CurrentCBWidth As Single
Dim TheCBItems As RECT
Dim ParentHdc As Long
Dim MyListCount As Long
Dim MyLongCounter As Long
Dim TempCBWidth As Long
Dim LongWidth As Long
Dim SavedFont As String
Dim SavedSize As Single
Dim SavedBold As Boolean
Dim SavedItalic As Boolean
Dim SavedUnderline As Boolean
Dim IsFontSaved As Boolean
On Error GoTo ErrorHandler
'Grab the combo handle and list count
ParentHdc = CB.Parent.hdc
MyListCount = CB.ListCount
If ParentHdc = 0 Or MyListCount = 0 Then Exit Function
'Save combo box fonts, etc. to the parent object(form),
'for testing lengths with the API
'My personal contribution
With CB.Parent
SavedFont = .FontName
SavedSize = .FontSize
SavedBold = .FontBold
SavedItalic = .FontItalic
SavedUnderline = .FontUnderline
.FontName = CB.FontName
.FontSize = CB.FontSize
.FontBold = CB.FontBold
.FontItalic = CB.FontItalic
.FontUnderline = CB.FontUnderline
End With
IsFontSaved = True
'Get the width of the widest item
For MyLongCounter = 0 To MyListCount
DrawText ParentHdc, CB.List(MyLongCounter), -1, TheCBItems, DT_CALCRECT
'Add twenty to the the number as a margin
TempCBWidth = TheCBItems.Right - TheCBItems.Left + 20
If (TempCBWidth > LongWidth) Then
LongWidth = TempCBWidth
End If
Next
'Get current width of combo
CurrentCBWidth = SendMessageLong(CB.hwnd, CB_GETDROPPEDWIDTH, 0, 0)
'If big enough then that's all A-OK
If CurrentCBWidth > LongWidth 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 LongWidth > Screen.Width \ Screen.TwipsPerPixelX - 20 Then _
LongWidth = Screen.Width \ Screen.TwipsPerPixelX - 20
'Set the width of our combo
LongReturn = SendMessageLong(CB.hwnd, CB_SETDROPPEDWIDTH, LongWidth, 0)
'Set the function to True/False depending on API success
AutosizeCombo = LongReturn > 0
ErrorHandler:
'If anything blows up, reset the combo to its original state
On Error Resume Next
If IsFontSaved Then
With CB.Parent
.FontName = SavedFont
.FontSize = SavedSize
.FontUnderline = SavedUnderline
.FontBold = SavedBold
.FontItalic = SavedItalic
End With
End If
End Function
'In the dropdown even of the combo box, place this code
Private Sub Combo1_DropDown()
Dim x As Variant
x = AutosizeCombo(Combo1)
End Sub
Reply With Quote
