Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0656: Spaltenüberschriften für eine mehrspaltige Listbox setzen

VB 5/6-Tipp 0656: Spaltenüberschriften für eine mehrspaltige Listbox setzen

 von Peter K. Sauer

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetDC, GetDialogBaseUnits, GetTextExtentPoint32A (GetTextExtentPoint32), ReleaseDC, SelectObject, SendMessageA (SendMessage)

Download: Download des Beispielprojektes [3,66 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 0)

Option Explicit

Private Sub Form_Load()
    Dim TabStops As String
    Dim HeaderCaptions As String
    
    Label1(0).AutoSize = True
   
    TabStops = "0,100,200,240"
    HeaderCaptions = "Name,Vorname, Plz,Ort"
      
    ListBoxTabStopsSet List1, TabStops
      
    With List1
        .AddItem Replace("Meier,Erich,1000,Berlin", ",", vbTab)
        .AddItem Replace("Huber,Franz,2000,Hamburg", ",", vbTab)
        .AddItem Replace("Schulze,Gunhilde,5000,Köln", ",", vbTab)
    End With
      
    ListBoxHeaderSet List1, TabStops, Label1, HeaderCaptions
End Sub

Private Sub Form_Resize()
    If Me.ScaleWidth > Me.List1.Left Then
        List1.Width = Me.ScaleWidth - 2 * List1.Left
    End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
Option Explicit

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long

Private Declare Function GetDialogBaseUnits Lib "user32.dll" () As Long

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, _
    ByVal hObject As Long) As Long
    
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" _
    Alias "GetTextExtentPoint32A" ( _
    ByVal hDC As Long, ByVal lpString As String, _
    ByVal cbString As Long, ByRef lpSize As SIZE) As Long
    
Private Declare Function ReleaseDC Lib "user32.dll" ( _
    ByVal hWnd As Long, ByVal hDC As Long) As Long
    
Private Type SIZE
    cx As Long
    cy As Long
End Type

Private Const WM_GETFONT As Long = &H31&
Private Const LB_SETTABSTOPS As Long = &H192

'TabStops in einer Listbox, Stops separated by Comma
'ListBoxTabStopsSet List1, "0,100,200,240"
Public Sub ListBoxTabStopsSet(Lbox As ListBox, StopList As String)
    Dim s() As String
    Dim Stops() As Long, i As Long
   
    s = Split(StopList, ",")
    ReDim Stops(UBound(s))
      
    For i = LBound(s) To UBound(s)
        Stops(i) = CLng(s(i))
    Next i
    i = UBound(Stops) + 1
      
    SendMessage Lbox.hWnd, LB_SETTABSTOPS, i, Stops(0)
End Sub

'eine Spaltenüberschrift für eine in Spalten geordnete Listbox
'übergeben wird ein Label mit Index=0
Public Sub ListBoxHeaderSet(Lbox As ListBox, StopList As String, _
    objLabel As Object, LabelCaptions As String, _
    Optional LabelTopFaktor As Single = 1.2)

    Dim s() As String
    Dim Stops() As Single, Units As Single
    Dim x As Single, y As Single
    Dim i As Long
    Dim Frm As Form
    
    Set Frm = Lbox.Parent
    
    s = Split(StopList, ",")
    ReDim Stops(UBound(s))
      
    For i = LBound(s) To UBound(s)
        Stops(i) = CLng(s(i))
    Next i

    For i = objLabel.UBound + 1 To UBound(Stops)
        Load objLabel(i)
        objLabel(i).Visible = True
    Next i
    
    'Breite eines Units in Pixeln
    Units = GetDialogUnitsPerPixel(Lbox.hWnd)
      
    s = Split(LabelCaptions, ",")
      
    y = Lbox.Top - (objLabel(0).Height * LabelTopFaktor)
    For i = 0 To UBound(Stops)
        If i = 0 Then
            x = Lbox.Left + Frm.ScaleX(2 + Units, vbPixels, Frm.ScaleMode)
        Else
            x = (Stops(i) + 1) * Units
            x = Frm.ScaleX(x + 0, vbPixels, Frm.ScaleMode) + Lbox.Left
        End If
        
        With objLabel(i)
            .Left = x
            .Top = y
            .Caption = s(i)
        End With
    Next i
    
    Set Frm = Nothing
End Sub

Private Function GetDialogUnitsPerPixel(ByVal hWnd As Long) As Single
    ' Device-Context des Controls ermitteln.
    Dim hDC As Long
    
    hDC = GetDC(hWnd)
    
    If hDC <> 0 Then
        Const Chars = _
        "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
        
        ' Selektieren des HFONT des Fensters in seinen DC (VB selektiert
        ' den Font des Steuerelements nicht in dessen DC).
        Dim hFont As Long
        hFont = SendMessage(hWnd, WM_GETFONT, 0&, ByVal 0&)
        
        Dim hFontOld As Long
        hFontOld = SelectObject(hDC, hFont)
        
        Dim sz As SIZE
        If GetTextExtentPoint32(hDC, Chars, Len(Chars), sz) <> 0 Then
            
            ' Durchschnittliche Zeichenbreite in Pixel (heuristisch).
            Dim AverageCharacterWidth As Long
            AverageCharacterWidth = sz.cx / Len(Chars)
            
            ' Horizontale Dialog-Base-Units ermitteln. Diese sind das
            ' Low-Order-Word von GetDialogBaseUnits.
            Dim DlgBaseX As Long
            DlgBaseX = GetDialogBaseUnits And &HFFFF&
            
            ' Anzahl der Dialog-Units pro Pixel zurückgeben.
            GetDialogUnitsPerPixel = _
                (2 * AverageCharacterWidth) / DlgBaseX
        End If
        
        Call SelectObject(hDC, hFontOld)
        Call ReleaseDC(hWnd, hDC)
    End If
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------