Tipp-Upload: VB 5/6 0087: Arrays benutzerdef. Typen nach bel. Reihenfolge sortieren mit HeapSort

Hinweis zum Tippvorschlag  

Dieser Vorschlag wurde noch nicht auf Sinn und Inhalt überprüft und die Zip-Datei wurde noch nicht auf schädlichen Inhalt hin untersucht.
Bitte haben Sie ein wenig Geduld, bis die Freigabe erfolgt.

Ü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:
Sortierverfahren, Sortieren, Heapsort,

Der Vorschlag wurde erstellt am: 29.08.2007 18:14.
Die letzte Aktualisierung erfolgte am 31.08.2007 11:14.

Zurück zur Übersicht

Beschreibung  

Hier wird gezeigt wie man mit dem HeapSort-Algorithmus Arrays bentzerdefinierter Typen, nach einer beliebigen Sortierreihenfolge, (Array aus Sortierkriterien), aufsteigend oder absteigend, sortieren kann. Der HeapSort-Code ist dabei allgemein anwendbar, lediglich die ausgelagerten Routinen Swap und Compare sind in eigenen Klassen anzupassen. Die Klasse "CPersonList" soll dabei nicht im Vordergrund stehen, sondern dient lediglich als anschauliches Beispiel.
Siehe auch Tipp:
"Arrays benutzerdef. Typen beliebig sortieren mit Quicksort"

Schwierigkeitsgrad

Verwendete API-Aufrufe: RtlMoveMemory, RtlZeroMemory, VarPtr (ArrPtr)

Download: Download des Beispielprojektes [4,75 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: Beschriftungsfeld "Label1"
' Steuerelement: Kontrollkästchen-Steuerelement "ChkDescending"
' Steuerelement: Listen-Steuerelement "List3"
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Schaltfläche "BtnSort"
' Steuerelement: Listen-Steuerelement "List1"

Option Explicit

Private mPersons As New CPersonList

Private Sub Form_Load()

    Dim i As Long

    With mPersons

        Call .SetLength(11)
        Call .SetItem(i, "Bob", "Thornton", CDate("18.09.2001"), "Oklahoma")
        Call .SetItem(i, "Bob", "Taylor", CDate("18.09.2001"), "New Jersey")
        Call .SetItem(i, "Peter", "Gabriel", CDate("09.08.2001"), "Vienna")
        Call .SetItem(i, "Peter", "Green", CDate("18.10.2002"), "Munich")
        Call .SetItem(i, "Mike", "Gabriel", CDate("13.05.1990"), "Oklahoma")
        Call .SetItem(i, "Mike", "Hammer", CDate("04.09.2003"), "New Jersey")
        Call .SetItem(i, "Mike", "Oldfield", CDate("18.09.2001"), "Munich")
        Call .SetItem(i, "John", "Thornton", CDate("09.08.2001"), "Vienna")
        Call .SetItem(i, "John", "Kennedy", CDate("09.08.2001"), "Oklahoma")
        Call .SetItem(i, "John", "Malkovich", CDate("30.09.2001"), "Vienna")
        Call .SetItem(i, "John", "Travolta", CDate("18.09.2001"), "Munich")

    End With

    Dim soA(): soA = Array("PreName", "FamName", "BirthDay", "City")

    For i = 0 To UBound(soA)

        Call List2.AddItem(soA(i))

    Next

    List2.ListIndex = 0
    List2_DblClick

    Call mPersons.ToListBox(List1)

End Sub

Private Sub List2_DblClick()

    Call MoveLBItem(List3, List2)

End Sub

Private Sub List3_DblClick()

    Call MoveLBItem(List2, List3)

End Sub

Private Sub MoveLBItem(DstLB As ListBox, SrcLB As ListBox)

    Call DstLB.AddItem(SrcLB.List(SrcLB.ListIndex))
    Call SrcLB.RemoveItem(SrcLB.ListIndex)

End Sub

Private Sub BtnSort_Click()

    If List3.ListCount > 0 Then

        Call mPersons.Sort(GetSortDirection, GetSortOrder)
        Call mPersons.ToListBox(List1)

    End If

End Sub

Private Function GetSortDirection() As SortDirection

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

End Function

Private Function GetSortOrder() As EPersonSortOrder()

    ReDim temp(0 To 0) As EPersonSortOrder

    Dim i As Long
    Dim n As Long: n = List3.ListCount

    If n > 0 Then
        ReDim temp(0 To n - 1)

        For i = 0 To n - 1

            If List3.List(i) = "PreName" Then
                temp(i) = soPreName
            ElseIf List3.List(i) = "FamName" Then
                temp(i) = soFamName
            ElseIf List3.List(i) = "BirthDay" Then
                temp(i) = soBirthDay
            ElseIf List3.List(i) = "City" Then
                temp(i) = soCity
            End If

        Next

    End If

    If temp(0) = 0 Then temp(0) = soPreName
    GetSortOrder = temp

End Function

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

' ------- 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 = 0

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

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

Option Explicit

Public Enum EPersonSortOrder
    soPreName = 1
    soFamName = 2
    soBirthDay = 3
    soCity = 4
End Enum

Private Type TPerson
    PreName  As String
    FamName  As String
    BirthDay As Date
    City     As String
End Type

Private mPersonArr() As TPerson
Private mSOArr() As EPersonSortOrder
Private mSD As SortDirection

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

' nur für den HeapSort-Sortieralgorithmus
Private mI1 As Long

Private Sub Class_Initialize()

    mTempLen = LenB(mTemp)

End Sub

Public Sub SetLength(LngVal As Long)

    ReDim mPersonArr(0 To LngVal - 1)

End Sub

Public Sub SetItem(x As Long, pn As String, fn As String, _
                   bd As Date, ct As String)

    If x > UBound(mPersonArr) Then Exit Sub

    With mPersonArr(x)
        .PreName = pn
        .FamName = fn
        .BirthDay = bd
        .City = ct
    End With

    x = x + 1

End Sub

Public Sub ToListBox(aLB As ListBox)

    Call aLB.Clear

    Dim i As Long
    Dim m1 As Long, m2 As Long, m3 As Long

    ' die Maximallänge der Felder herausfinden
    For i = LBound(mPersonArr) To UBound(mPersonArr)
        m1 = MaxL(m1, Len(mPersonArr(i).PreName))
        m2 = MaxL(m2, Len(mPersonArr(i).FamName))
        m3 = MaxL(m3, Len(mPersonArr(i).City))
    Next

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

        Call aLB.AddItem(PadRight(mPersonArr(i).PreName, m1) & "  " & PadRight(mPersonArr( _
            i).FamName, m2) & "  " & Format$(mPersonArr(i).BirthDay, "dd.mm.yyyy") & "  " & _
            PadRight(mPersonArr(i).City, m3))

    Next

End Sub

Public Sub Sort(ByVal aSortDirection As SortDirection, _
                ByRef SortOrders() As EPersonSortOrder)

    mSD = aSortDirection
    mSOArr = SortOrders

    Call HeapSort(LBound(mPersonArr), UBound(mPersonArr))

    #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
    Dim i As Long
    Dim c As Long

    For i = 0 To UBound(mSOArr)

        Select Case mSOArr(i)

        Case soPreName
            c = StrComp(mPersonArr(i1).PreName, mPersonArr(i2).PreName, vbBinaryCompare)

        Case soFamName
            c = StrComp(mPersonArr(i1).FamName, mPersonArr(i2).FamName, vbBinaryCompare)

        Case soBirthDay

            If mPersonArr(i1).BirthDay > mPersonArr(i2).BirthDay Then
                c = 1
            ElseIf mPersonArr(i1).BirthDay < mPersonArr(i2).BirthDay Then
                c = -1
            End If

        Case soCity
            c = StrComp(mPersonArr(i1).City, mPersonArr(i2).City, vbBinaryCompare)

        End Select

        If c <> 0 Then
            If mSD = SortDirection_Descending Then c = -1 * c

            Exit For

        End If

    Next

    Compare = c

End Function

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

    #If INeedForSpeed Then

        ' mTempLen-Bytes von i1 nach mTempBytes kopieren
        Call RtlMoveMemory(ByVal VarPtr(mTemp), ByVal VarPtr(mPersonArr(i1)), mTempLen)

        ' mTempLen-Bytes von i2 nach i1Ptr kopieren
        Call RtlMoveMemory(ByVal VarPtr(mPersonArr(i1)), ByVal VarPtr(mPersonArr(i2)), mTempLen)

        ' mTempLen-Bytes von mTempBytes nach i2 kopieren
        Call RtlMoveMemory(ByVal VarPtr(mPersonArr(i2)), ByVal VarPtr(mTemp), mTempLen)

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

End Sub

#If INeedForSpeed Then

    Private Sub DisposeTemp()

        Call RtlZeroMemory(mTemp, mTempLen)

    End Sub

#End If

' HeapSort
' Dieser HeapSort-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.
' HeapSort
Private Sub HeapSort(ByVal i1 As Long, ByVal i2 As Long)

    mI1 = i1

    Dim n As Long
    n = i2 - i1 + 1

    ' Debug.Print "BuildHeap"
    Call BuildHeap(n)

    ' Debug.Print "SortHeap"
    Dim i As Long

    For i = n - 1 To 0 Step -1

        Call XSwap(i, 0)
        Call DownHeap(0, i)

    Next

End Sub

Private Sub BuildHeap(ByVal n As Long)

    Dim i As Long

    For i = n / 2 - 1 To 0 Step -1

        Call DownHeap(i, n)

    Next

End Sub

Private Sub DownHeap(ByVal i As Long, ByVal n As Long)

    ' Debug.Print "  DownHeap"
    Dim w As Long

    While (i <= (n / 2) - 1)
        w = ((i + 1) * 2) - 1

        If w + 1 <= n - 1 Then
            If XComp(w, w + 1) < 0 Then
                w = w + 1
            End If
        End If

        If XComp(i, w) < 0 Then

            Call XSwap(i, w)

            i = w
        Else

            Exit Sub

        End If

    Wend

End Sub

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

    XComp = Compare(mI1 + i1, mI1 + i2)

End Function

Private Sub XSwap(ByVal i1 As Long, ByVal i2 As Long)

    Call Swap(mI1 + i1, mI1 + i2)

End Sub

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

' -------------- 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.