Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0590: Listboxeinträge rechtsbündig ausrichten

VB 5/6-Tipp 0590: Listboxeinträge rechtsbündig ausrichten

 von Peter K. Sauer

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4,51 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 -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "Command6"
' Steuerelement: Schaltfläche "Command5"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Sub Command1_Click()
    Dim s As String
    Dim i As Long
    Dim aTime As Single
    
    'Daten in List- und Combobox laden
    List1.Clear
    Combo1.Clear
    aTime = Timer
    
    For i = 1 To 50
        s = Format(Int(Rnd * 10000000 + 100) / 100, "#,##0.00")
        List1.AddItem s
        Combo1.AddItem s
    Next
    
    Print Format(Timer - aTime, "0.00000")
End Sub

Private Sub Command2_Click()
    'rechtsbündig ausrichten
    Dim aTime As Single
    
    'Zeitmessung
    aTime = Timer
    
    BoxSetRightAlign Me, List1
    BoxSetRightAlign Me, Combo1
    
    'wie lange hat's gedauert
    Print Format(Timer - aTime, "0.00000")
End Sub

Private Sub Command3_Click()
    'rechtbündig auf Stellenanzahl ausrichten
    
    Dim aTime As Single
    
    'Zeitmessung
    aTime = Timer
    
    BoxSetRightAlign Me, List1, 15
    BoxSetRightAlign Me, Combo1, 15
    
    'wie lange hat's gedauert
    Print Format(Timer - aTime, "0.00000")
End Sub

Private Sub Command4_Click()
    Dim Result As String
    
    Result = Format(Int(Rnd * 10000000 + 100) / 100, "#,##0.00")
    Result = InputBox("neuer Eintrag für List- und/oder Combobox", _
        "BoxRightAlign", Result)
    
    If Len(Result) = 0 Then
        Exit Sub
    End If
    
    BoxSetRightAlignAddItem Me, List1, Result, "4711", List1.ListCount
    BoxSetRightAlignAddItem Me, Combo1, Result, "4711", Combo1.ListCount
End Sub

Private Sub Command5_Click()
    Dim Result As String
    
    Result = Format(Int(Rnd * 10000000 + 100) / 100, "#,##0.00")
    Result = InputBox("neuer Eintrag für List- und/oder Combobox", _
        "BoxRightDigits", Result)
    
    If Len(Result) = 0 Then
        Exit Sub
    End If
    
    BoxSetRightAlignAddItem Me, List1, Result, "4711", List1.ListCount, 15
    BoxSetRightAlignAddItem Me, Combo1, Result, "4711", Combo1.ListCount, 15
End Sub

Private Sub Command6_Click()
    With CommonDialog1
        On Error Goto Abbruch
        .Flags = cdlCFScreenFonts Or cdlCFEffects
        .CancelError = True
        .FontName = List1.FontName
        .ShowFont
    End With
    
    'Fonteigenschaften zuweisen
    FontSetFont List1, CommonDialog1
    FontSetFont Combo1, CommonDialog1

Abbruch:
End Sub

Private Sub Form_Load()
    Dim s As String
    Dim i As Long
    
    'Daten in List- und Combobox laden
    For i = 1 To 50
        s = Format(Int(Rnd * 10000000 + 100) / 100, "#,##0.00")
        List1.AddItem s
        Combo1.AddItem s
    Next
    
    Command1.Caption = "New Items"
    Command2.Caption = "RightAlign"
    Command3.Caption = "Right Digits"
    Command4.Caption = "Add Right"
    Command5.Caption = "Add RightDigits"
    Command6.Caption = "Change Font"
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

'--------------------------------------------------------
'
'      Module List- Or ComboBox RightAlign  3.2003
'
'      (c) peter.k.sauer@web.de
'--------------------------------------------------------
'      ausrichten einer List- oder Combobox rechtsbündig
'      löschen, neu schreiben geht schneller als Update
'--------------------------------------------------------

'Saven eines Fonts
Public Type FontSaveType
    FontName As String
    FontSize As Long
    FontBold As Boolean
    FontItalic As Boolean
    FontUnderline As Boolean
    FontStrikethru As Boolean
End Type

Public Sub BoxSetRightAlign(objDestination As Object, _
        objBox As Object, Optional DigitCount As Long = 0)
    'Alle Items in List- oder Combobox rechtsbündig ausrichten
    'ObjectDestination ist eine Form oder eine Picturebox, die für die
    'Berechnung der Textbreite benötigt wird
    'objBox ist eine List- oder Combobox

    Dim ListCount As Long
    Dim i As Long
    Dim s() As String
    Dim FontSave As FontSaveType
    
    ListCount = objBox.ListCount
    objBox.Visible = False
    
    'Box Items in Array auslesen und dann löschen
    ReDim s(ListCount, 1)
    For i = 0 To ListCount - 1
        s(i, 0) = objBox.List(i)
        s(i, 1) = Str$(objBox.ItemData(i))
    Next
    objBox.Clear
    
    'Font objDestination save
    FontSaveFont objDestination, FontSave
    
    'Font der Box zuweisen
    FontSetFont objDestination, objBox
    
    'rechtsbündig ausgerichtet in Box neu abstellen
    For i = 0 To ListCount - 1
        objBox.AddItem BoxSetItemRightAlign(objDestination, _
                            objBox, s(i, 0), ListCount, DigitCount)
        objBox.ItemData(objBox.NewIndex) = Val(s(i, 1))
    Next
    
    'Restore Font
    FontRestoreFont objDestination, FontSave
    objBox.Visible = True
End Sub

Public Sub BoxSetRightAlignAddItem(objDestination As Object, _
        objBox As Object, NewItem As String, Optional ItemData As String = "", _
        Optional ListCount As Long = -1, Optional DigitCount As Long = 0)
    'einer List- oder Combobox einen Eintrag rechtsbündig hinzufügen

    Dim mListCount As Long
    Dim FontSave As FontSaveType

    If mListCount - 1 Then
        mListCount = objBox.ListCount
    End If
    
    objBox.Visible = False
    
    'Font objDestination save
    FontSaveFont objDestination, FontSave
    'Font der Box zuweisen
    FontSetFont objDestination, objBox
    'Restore Font
    
    objBox.AddItem BoxSetItemRightAlign(objDestination, _
                        objBox, NewItem, mListCount, DigitCount)
    objBox.ItemData(objBox.NewIndex) = ItemData
  
    FontRestoreFont objDestination, FontSave
    objBox.Visible = True
End Sub

Private Function BoxSetItemRightAlign(objDestination As Object, _
        objBox As Object, sString As String, ListCount As Long, _
        Optional DigitCount As Long = 0) As String
        
    'liefert ein Item in  List- oder Combobox rechtsbündig ausgerichtet
    
    Dim s As String
    Dim w As Single, w1 As Single
    Dim h As Single, h1 As Single
    Dim WithScroll As Boolean
    Dim AnzSpace As Long
    
    'hat die objBox einen Scrollbalken oder ist Combo
    h = objBox.Height - 60
    h1 = objDestination.TextHeight(s) * ListCount
    If (h1 > h) Or (TypeOf objBox Is ComboBox) Then
        WithScroll = True
    End If
    
    'Imtem laden
    s = Trim(sString)
    
    'Breite feststellen
    w = objDestination.TextWidth(s)
    
    'Boxbreite festellen oder Breite nach Anzahl Digits
    If DigitCount > 0 Then
        w1 = objDestination.TextWidth(String$(DigitCount, "0"))
        
        'den Scrollbalken berücksichtigen
        If (TypeOf objBox Is ComboBox) Or WithScroll Then
            w1 = w1 + 285
        End If
    Else
        If TypeOf objBox Is ComboBox Then
            w1 = objBox.Width - 105
        Else
            w1 = objBox.Width - 135
        End If
    End If
    
    'hat die objBox einen Scrollbalken oder ist Combo
    If WithScroll Then
        w1 = w1 - 285
    End If
    
    'vorlaufende Spaces ausrechnen
    If objDestination.FontBold Or objDestination.FontItalic Then
        
        'eigenartiges Verhalten bei Bold und Italic
        Do While objDestination.TextWidth(s & Space$(1)) < w1
            s = Space(1) & s
        Loop
    Else
        If w1 < w Then
            w1 = w
        End If
        AnzSpace = (w1 - w) \ objDestination.TextWidth(Space$(1))
        s = Space$(AnzSpace) & s
    End If
    
    'liefert den String
    BoxSetItemRightAlign = s
End Function

Public Sub FontSaveFont(SourceObject As Object, _
           FontSave As FontSaveType)
    'übergibt in eine Variable vom Typ FontSaveType den Font
    'eines QuellObjects
    
    With FontSave
        .FontName = SourceObject.FontName
        .FontSize = SourceObject.FontSize
        .FontItalic = SourceObject.FontItalic
        .FontUnderline = SourceObject.FontUnderline
        .FontStrikethru = SourceObject.FontStrikethru
    End With
End Sub

Public Sub FontRestoreFont(DestinationObject As Object, _
           FontSave As FontSaveType)
    'stellt im Destination Object den über FontSaveFont gepeicherten
    'Font Zustand wieder her

    With FontSave
        DestinationObject.FontName = .FontName
        DestinationObject.FontSize = .FontSize
        DestinationObject.FontItalic = .FontItalic
        DestinationObject.FontUnderline = .FontUnderline
        DestinationObject.FontStrikethru = .FontStrikethru
    End With

End Sub

Public Sub FontSetFont(objDestination As Object, objSource As Object)
    'Font eines Objects (List-/Combobox) übergeben an Form, Picbox, Printer

    With objDestination
        .FontName = objSource.FontName
        .FontSize = objSource.FontSize
        .FontBold = objSource.FontBold
        .FontItalic = objSource.FontItalic
        .FontUnderline = objSource.FontUnderline
        .FontStrikethru = objSource.FontStrikethru
    End With
End Sub


'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.