Automatická šířka seznamu v ComboBoxu

Funkce:
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
    
    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

    'Zjištění ukazatele na combo a počet položek
    lngParentHDC = Combo.Parent.hdc
    lngListCount = Combo.ListCount

    If lngParentHDC = 0 Or lngListCount = 0 Then Exit Function

    'Uložení fontů atd. comba na rodičovský objekt(formulář) pro testování
    'délky s 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

    'Zjištění délky nejdelší položky
    For lngCounter = 0 To lngListCount
       DrawText lngParentHDC, Combo.List(lngCounter), -1, rectCboText, _
            DT_CALCRECT

        'Přidání 20 jako okraje
       lngTempWidth = rectCboText.Right - rectCboText.Left + 20

        If (lngTempWidth > lngWidth) Then
           lngWidth = lngTempWidth
        End If

    Next
 
    'Zjištění aktuální délky comba
     lngCurrentWidth = SendMessageLong(Combo.hwnd, _
        CB_GETDROPPEDWIDTH, 0, 0)

    'Je-li to dost, je to v pořádku
    If lngCurrentWidth > lngWidth Then

        AutosizeCombo = True
        GoTo ErrorHandler
        Exit Function
    
    End If
 
    '... ale pokud ne, pak musíme nejprve zjistit délku obrazovky a přesvědčit se,
    'zda tuto hodnotu nepřekročíme
     If lngWidth > Screen.Width \ Screen.TwipsPerPixelX - 20 Then _
        lngWidth = Screen.Width \ Screen.TwipsPerPixelX - 20

    'Nastavení délky comba
    lngRet = SendMessageLong(Combo.hwnd, _
       CB_SETDROPPEDWIDTH, lngWidth, 0)

    'Nastavení True/False v závislosti na úspěšnosti API
    AutosizeCombo = lngRet > 0
    
ErrorHandler:
    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

Použití (v proměnné x bude True/False podle úspěchu funkce):
x = AutosizeCombo(Combo1)

Zpět

Autor: The Bozena