Public 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 Public Const CB_GETLBTEXTLEN = &H149 Public Const CB_SHOWDROPDOWN = &H14F Public Const CB_GETDROPPEDWIDTH = &H15F Public Const CB_SETDROPPEDWIDTH = &H160 'APIs to set determine the font width Public Type SIZE cx As Long cy As Long End Type Public Declare Function SelectObject Lib "gdi32" _ (ByVal hDc As Long, ByVal hObject As Long) As Long Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A _ (ByVal hDc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Public Const ANSI_FIXED_FONT = 11 Public Const ANSI_VAR_FONT = 12 Public Const SYSTEM_FONT = 13 Public Const DEFAULT_GUI_FONT = 17 'win95 only Add the following code to the bas module: Public Function GetFontDialogUnits() As Long Dim hFont As Long Dim hFontOld As Long Dim r As Long Dim avgWidth As Long Dim hDc As Long Dim tmp As String Dim sz As SIZE 'get the hdc to the main window hDc = GetDC(Form1.hwnd) 'with the current font attributes, select the font hFont = GetStockObject(ANSI_VAR_FONT) hFontOld = SelectObject(hDc, hFont&) 'get it's length, then calculate the average character width tmp = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" r = GetTextExtentPoint32(hDc, tmp, 52, sz) avgWidth = (sz.cx \ 52) 're-select the previous font & delete the hDc r = SelectObject(hDc, hFontOld) r = DeleteObject(hFont) r = ReleaseDC(Form1.hwnd, hDc) 'return the average character width GetFontDialogUnits = avgWidth End Function Add the following code to the form: Private Sub cmdAdjManual_Click() Dim r As Long Dim NewDropDownWidth As Long 'first, check if a number is entered into Text1. If not, bail out. If Val(Text1) <= 0 Then Exit Sub 'here we simply set the dropdown list size to the value entered in Text1. 'Note: If the proposed width this is _less_ than the width of the combo portion, the combo 'width is used (the dropdown can never be narrower than the combobox) NewDropDownWidth = Val(Text1) 'resize the dropdown portion of the combo box using SendMessageLong r = SendMessageLong(Combo1.hwnd, CB_SETDROPPEDWIDTH, NewDropDownWidth, 0) 'reflect the new dropdown list width in the Label r = SendMessageLong(Combo1.hwnd, CB_GETDROPPEDWIDTH, 0, 0) Label1 = "Current dropdown width = " & r & " pixels." 'Finally, drop the list down by code to show the new size r = SendMessageLong(Combo1.hwnd, CB_SHOWDROPDOWN, True, 0) End Sub Private Sub cmdAdjCombol_Click() Dim r As Long Dim i As Long Dim NumOfChars As Long Dim LongestComboItem As Long Dim avgCharWidth As Long Dim NewDropDownWidth As Long 'loop through the combo entries, using SendMessageLong 'with CB_GETLBTEXTLEN to determine the longest item 'in the dropdown portion of the combo For i = 0 To Combo1.ListCount - 1 NumOfChars = SendMessageLong(Combo1.hwnd, CB_GETLBTEXTLEN, i, 0) If NumOfChars > LongestComboItem& Then LongestComboItem = NumOfChars Next 'get the average size of the characters using the GetFontDialogUnits API. Because a dummy 'string is used in GetFontDialogUnits, avgCharWidth is an approximation based on that string. avgCharWidth = GetFontDialogUnits() 'compute the size the dropdown needs to be to accommodate the longest string. Here I subtract '2 because I find that on my system, using the dummy string in GetFontDialogUnits, the width 'is just a bit too wide. NewDropDownWidth = (LongestComboItem - 2) * avgCharWidth 'resize the dropdown portion of the combo box r = SendMessageLong(Combo1.hwnd, CB_SETDROPPEDWIDTH, NewDropDownWidth, 0) 'reflect the new dropdown list width in Label2 and in Text1 r = SendMessageLong(Combo1.hwnd, CB_GETDROPPEDWIDTH, 0, 0) Label1 = "Current dropdown width = " & r & " pixels." Text1 = r 'finally, drop the list down by code to show the new size r = SendMessageLong(Combo1.hwnd, CB_SHOWDROPDOWN, True, 0) End Sub |