Tipp-Upload: VB 5/6 0065: Felder benutzerdefinierter Typen sortieren mit Quicksort

von OlimilO

Über den Tipp

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

Mathematik
Sonstiges

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Sort, Sortieren, Sortierroutinen, Quicksort, ascending, descending, aufsteigend, absteigend

Damit er übernommen werden kann, müssen noch Änderungen daran vorgenommen werden. Sofern Sie der Autor sind, können Sie sich anmelden, um die Liste einzusehen.

Der Vorschlag wurde erstellt am: 29.07.2007 18:32.
Die letzte Aktualisierung erfolgte am 24.02.2008 14:22.

Zurück zur Übersicht

Beschreibung

Hier wird gezeigt wie man mit dem Quicksort-Algorithmus Felder bentzerdefinierter Typen, nach einem beliebigen Sortierkriterium, aufsteigend oder absteigend, sortieren kann. Der Quicksort-Algorithmus ist dabei allgemein anwendbar, lediglich die ausgelagerten Routinen Swap und Compare sind in eigenen Klassen anzupassen. Die Klasse "CFileList" soll dabei nicht im Vordergrund stehen, sondern dient als anschauliches Beispiel.

Dieser Tipp dient als Ergänzung zu:
* "Daten sortieren [FAQ 0127]"
* "Sortieren mit Quicksort [Tipp 0188]"
* "Sortieren mehrdimensionaler Arrays mit Quicksort [Tipp 0547]"
* Tutorial Schnittstellen von Helge Rex.

Schwierigkeitsgrad

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

RtlMoveMemory, RtlZeroMemory, VarPtr (ArrPtr)

Download:

Download des Beispielprojektes [4,28 KB]

' Dieser Source 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: Kontrollkästchen-Steuerelement "ChkDescending"
' Steuerelement: Optionsfeld-Steuerelement "Option2" auf Frame1
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "Option1" auf Frame1
' Steuerelement: Optionsfeld-Steuerelement "Option3" auf Frame1
' Steuerelement: Listen-Steuerelement "List1"

Option Explicit

' Nur eine Beispielklasse die die zu sortoerenden Daten beinhaltet
Private mFiles As New CFileList

Private Sub Form_Load()

    Dim i As Long

    ' Einige Datensätze anlegen, dienen nur als Beispiel;
    With mFiles

        Call .SetLength(7)
        Call .SetItem(i, "C:\ErsteDatei.txt", 84626, CDate("3.3.1989"))
        Call .SetItem(i, "C:\ErsteDatie.txt", 74626, CDate("3.3.1989"))
        Call .SetItem(i, "C:\ZweiteDatei.txt", 12456, CDate("12.9.1991"))
        Call .SetItem(i, "C:\DritteDatei.txt", 66456, CDate("18.1.1990"))
        Call .SetItem(i, "C:\VierteDatei.txt", 45672, CDate("24.6.1986"))
        Call .SetItem(i, "C:\FünfteDatei.txt", 41172, CDate("9.8.1992"))
        Call .SetItem(i, "C:\SechsteDatei.txt", 31872, CDate("9.8.1992"))

    End With

    Option1.Value = True

End Sub

Private Sub Sort()

    Call mFiles.Sort(GetSortDirection, GetFileSortOrder)
    Call mFiles.ToListBox(List1)

End Sub

Private Function GetSortDirection() As SortDirection

    GetSortDirection = IIf (ChkDescending.Value = vbChecked, SortDirection_Descending, _
        SortDirection_Ascending)

End Function

Private Function GetFileSortOrder() As EFileSortOrder

    If Option1.Value Then
        GetFileSortOrder = soFileName
    ElseIf Option2.Value Then
        GetFileSortOrder = soFileLen
    Else
        GetFileSortOrder = soFileDate
    End If

End Function

Private Sub Option1_Click()

    Call Sort

End Sub

Private Sub Option2_Click()

    Call Sort

End Sub

Private Sub Option3_Click()

    Call Sort

End Sub

Private Sub ChkDescending_Click()

    Call Sort

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' ------ Anfang Klasse "CFileList" alias CFileList.cls  ------

Option Explicit

Public Enum EFileSortOrder
    soFileName = 1
    soFileLen = 2
    soFileDate = 3
End Enum

Private Type TMyFile
    FileName As String
    FileLen  As Long
    FileDate As Date
End Type

Private mFileArr() As TMyFile
Private mSO As EFileSortOrder
Private mSD As SortDirection

' nur für den Vertauschvorgang beim Sortieren:
Private mTemp As TMyFile
Private mTempLen As Long

Private Sub Class_Initialize()

    mTempLen = LenB(mTemp)

End Sub

Public Sub SetLength(LngVal As Long)

    ReDim mFileArr(0 To LngVal - 1)

End Sub

Public Sub SetItem(x As Long, aFileName As String, _
                   aFLen As Long, aDate1 As Date)

    If x > UBound(mFileArr) Then Err.Raise (9)

    With mFileArr(x)
        .FileName = aFileName
        .FileLen = aFLen
        .FileDate = aDate1
    End With

    x = x + 1

End Sub

Public Sub ToListBox(aLB As ListBox)

    Call aLB.Clear

    Dim i As Long
    Dim m As Long

    For i = LBound(mFileArr) To UBound(mFileArr)
        m = MaxL(m, Len(mFileArr(i).FileName))
    Next

    For i = LBound(mFileArr) To UBound(mFileArr)

        Call aLB.AddItem(PadRight(mFileArr(i).FileName, m) & "   " & CStr(mFileArr( _
            i).FileLen) & "   " & Format$(mFileArr(i).FileDate, "dd.mm.yyyy"))

    Next

End Sub

Public Sub Sort(ByVal aSortDirection As SortDirection, _
                ByVal aSortOrder As EFileSortOrder)

    mSD = aSortDirection
    mSO = aSortOrder

    Call QuickSort(LBound(mFileArr), UBound(mFileArr))

    #If INeedForSpeed Then

        Call DisposeTemp

    #End If

End Sub

Private Function Compare(ByVal i1 As Long, _
                         ByVal i2 As Long) As Long

    ' Wenn Ascending dann:
    ' gibt < 0 wenn i1 < i2
    ' gibt = 0 wenn i1 = i2
    ' gibt > 0 wenn i1 > i2
    ' bei Descending umgekehrt
    Select Case mSO

    Case soFileName
        Compare = StrComp(mFileArr(i1).FileName, mFileArr(i2).FileName, vbBinaryCompare)

    Case soFileLen

        If mFileArr(i1).FileLen > mFileArr(i2).FileLen Then
            Compare = 1
        ElseIf mFileArr(i1).FileLen < mFileArr(i2).FileLen Then
            Compare = -1
        End If

    Case soFileDate

        If mFileArr(i1).FileDate > mFileArr(i2).FileDate Then
            Compare = 1
        ElseIf mFileArr(i1).FileDate < mFileArr(i2).FileDate Then
            Compare = -1
        End If

    End Select

    If Compare <> 0 Then
        If mSD = SortDirection_Descending Then Compare = -1 * Compare
    End If

End Function

Private Sub Swap(i1 As Long, i2 As Long)

    #If INeedForSpeed Then

        ' mTempLen = 2 * 4 + 8 = 16Bytes
        ' 16Byte von i1 nach mTemp kopieren
        Call RtlMoveMemory(ByVal VarPtr(mTemp), ByVal VarPtr(mFileArr(i1)), mTempLen)

        ' 16Byte von i2 nach i1 kopieren
        Call RtlMoveMemory(ByVal VarPtr(mFileArr(i1)), ByVal VarPtr(mFileArr(i2)), mTempLen)

        ' 16Byte von mTemp nach i2 kopieren
        Call RtlMoveMemory(ByVal VarPtr(mFileArr(i2)), ByVal VarPtr(mTemp), mTempLen)

    #Else
        mTemp = mFileArr(i1)
        mFileArr(i1) = mFileArr(i2)
        mFileArr(i2) = mTemp
    #End If

End Sub

#If INeedForSpeed Then

    Private Sub DisposeTemp()

        Call RtlZeroMemory(mTemp, mTempLen)

    End Sub

#End If

' QuickSort
' Dieser QuickSort-Algorithmus ist unabhängig von den zu sortierenden
' Daten, da der Vergleich von Daten (Compare) und ein Vertauschen der
' Daten (Swap) aus dem Algorithmus in andere Routinen ausgelagert ist.
Private Sub QuickSort(ByVal i1 As Long, ByVal i2 As Long)

    Dim t As Long

    If i2 > i1 Then
        t = divide(i1, i2)

        Call QuickSort(i1, t - 1)
        Call QuickSort(t + 1, i2)

    End If

End Sub

Private Function divide(ByVal i1 As Long, ByVal i2 As Long) As Long

    Dim i As Long, j As Long, p As Long
    i = i1 - 1
    j = i2
    p = j

    Do
        Do
            i = i + 1
        Loop While (Compare(i, p) < 0)

        Do
            j = j - 1
        Loop While ((i1 < j) And (Compare(p, j) < 0))

        If i < j Then Call Swap(i, j)
    Loop While (i < j)

    Call Swap(i, p)

    divide = i

End Function

' ------- Ende Klasse "CFileList" alias CFileList.cls  -------

' ------- Anfang Modul "ModSystem" alias ModSystem.bas -------

Option Explicit

' wird hier die Compiler-Konstante gleich 1 gesetzt, wird der
' Vertauschungsvorgang zweier Datensätze mit RtlMoveMemory
' durchgeführt, dies hat den Vorteil, daß nur die Zeiger auf
' Stringdaten vertauscht werden, und keine Stringdaten selbst
' kopiert werden müssen.
#Const INeedForSpeed = 1

Public Enum SortDirection
    SortDirection_Ascending = 0
    SortDirection_Descending = 1
End Enum

Public Declare Function ArrPtr Lib "msvbvm60" _
                        Alias "VarPtr" ( _
                        ByRef pArr() As Any) As Long

Public Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
                   ByRef pDst As Any, _
                   ByRef pSrc As Any, _
                   ByVal Length As Long)

Public Declare Sub RtlZeroMemory Lib "kernel32.dll" ( _
                   ByRef pDst As Any, _
                   ByVal Length As Long)

' Nur ein paar Hilfsfunktionen
' Math
Public Function MaxL(Val1 As Long, Val2 As Long) As Long

    If Val1 > Val2 Then MaxL = Val1 Else MaxL = Val2

End Function

' String
Public Function PadRight(StrVal As String, _
                         ByVal totalWidth As Long, _
                         Optional ByVal paddingChar As String) As String

    ' der String wird mit der angegebenen Länge zurückgegeben, der
    ' String wird nach links gerückt, und rechts mit PadChar aufgefüllt
    ' ist PadChar nicht angegeben, so wird mit LSet der String in
    ' Spaces eingefügt.
    If Len(paddingChar) Then

        If Len(StrVal) <= totalWidth Then PadRight = StrVal & String$(totalWidth - Len( _
            StrVal), paddingChar)

    Else
        PadRight = Space$(totalWidth)
        LSet PadRight = StrVal
    End If

End Function

' -------- Ende Modul "ModSystem" alias ModSystem.bas --------

' -------------- Ende Projektdatei Projekt1.vbp --------------

Diskussion

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.