Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0638: Eine Listbox schnell sortieren

VB 5/6-Tipp 0638: Eine Listbox schnell sortieren

 von Konrad Doblander

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [2,83 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: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Listen-Steuerelement "List1"

Option Explicit

' ListBox-Einträge sortieren
' LB Sorted = False sonst wird autom. aufsteigend sortiert!
Public Function LBSortItem(ByRef hLBox As ListBox, _
                           ByRef hOrder As Boolean) As Boolean
    
    Dim rApi        As Long
    Dim idx         As Integer
    Dim maxElements As Integer
    Dim tmpLB()     As String
    
    Debug.Print Timer & " " & Time$
    If hOrder = True Then
        
        'LB-Sortierung absteigend
        If hLBox.Sorted = True Then
            
            ' kann nicht sortiert werden !
            LBSortItem = False
            Exit Function
        End If
        
    Else
        
        ' LB-Sortierung aufsteigend (Standard!)
        If hLBox.Sorted = True Then
        
            'keine weitere Sortierung notwendig!
            LBSortItem = True
            Exit Function
        End If
    End If
    
    ' Einträge sortieren
    ' zuerst alle Einträge in Array u. sortieren
    ReDim tmpLB(hLBox.ListCount - 1)
    maxElements = hLBox.ListCount
    For idx = 0 To hLBox.ListCount - 1
        tmpLB(idx) = hLBox.List(idx)
    Next
    
    ' Array sortieren
    'Call SortArray1(tmpLB())  ' zu langsam
    Call SortArray2(tmpLB(), 0, maxElements - 1)
    
    ' LB löschen/leeren u. wieder füllen
    hLBox.Clear
    For idx = 0 To maxElements - 1
        If hOrder = True Then
           hLBox.AddItem tmpLB(idx), 0
        Else
           hLBox.AddItem tmpLB(idx)
        End If
    Next
    Debug.Print Timer; " "; Time$
End Function

' Array sortieren - Variante 1   >BubbleSort<
'  < 1 sek. bei 1.000 / ca. 1 min bei 10.000 Strings
Public Sub SortArray1(ByRef tmpArray() As String)
    Dim tmpString   As String
    Dim sortIdx     As Long
    Dim sortFlag    As Boolean
    
    sortFlag = True
    Do While sortFlag = True
       sortFlag = False
       For sortIdx = 1 To UBound(tmpArray())
           If tmpArray(sortIdx) < tmpArray(sortIdx - 1) Then
              tmpString = tmpArray(sortIdx)
              tmpArray(sortIdx) = tmpArray(sortIdx - 1)
              tmpArray(sortIdx - 1) = tmpString
              sortFlag = True
           End If
       Next
    Loop
End Sub

' Array sortieren - Variante 2   >QuickSort<
'  < 1 sek. bei 1.000 / ca. 1 sek bei 10.000 Strings
Public Sub SortArray2(ByRef tmpArray() As String, ByVal idxLo As Long, ByVal idxHi As Long)
  Dim tmpString As String
  Dim tmpSwap   As String
  Dim tmpLow    As Long
  Dim tmpHi     As Long
  
  tmpLow = idxLo
  tmpHi = idxHi
  tmpString = tmpArray((idxLo + idxHi) / 2)
  
  While (tmpLow <= tmpHi)
    While (tmpArray(tmpLow) < tmpString) And (tmpLow < idxHi)
      tmpLow = tmpLow + 1
    Wend
  
    While (tmpString < tmpArray(tmpHi)) And (tmpHi > idxLo)
      tmpHi = tmpHi - 1
    Wend
  
    If (tmpLow <= tmpHi) Then
      tmpSwap = tmpArray(tmpLow)
      tmpArray(tmpLow) = tmpArray(tmpHi)
      tmpArray(tmpHi) = tmpSwap
      tmpLow = tmpLow + 1
      tmpHi = tmpHi - 1
    End If
  Wend
   
  If (idxLo < tmpHi) Then SortArray2 tmpArray(), idxLo, tmpHi
  If (tmpLow < idxHi) Then SortArray2 tmpArray(), tmpLow, idxHi
End Sub

'Sortieren (absteigend)
Private Sub Command2_Click()
    LBSortItem List1, True
End Sub

'Sortieren (aufsteigend)
Private Sub Command3_Click()
    LBSortItem List1, False
End Sub

Private Sub Form_Load()
    Command1.Caption = "Mischen"
    Command2.Caption = "Sortieren (aufsteigend)"
    Command3.Caption = "Sortieren (absteigend)"
    
    Call Command1_Click
End Sub

Private Sub Command1_Click()
    Dim temp As String
    Dim i As Integer
    Dim j As Integer
    
    List1.Clear
    
    'Die Liste mi 10.000 Einträgen, die 5 Zeichen lang sind, füllen.
    For i = 1 To 10000
        For j = 1 To 5
            temp = temp & RandomChar()
        Next j
        
        List1.AddItem temp
        temp = ""
    Next i
End Sub

'Einen zufälligen Buchstaben ausgeben
Private Function RandomChar() As String
    Const CHARS As String = _
        "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
    
    Randomize Timer
    RandomChar = Mid(CHARS, Int(Rnd * (Len(CHARS))) + 1, 1)
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------