Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0565: Bubblesort-Algorithmus mit n-Fachen Gruppierungsmöglichkeit

VB 5/6-Tipp 0565: Bubblesort-Algorithmus mit n-Fachen Gruppierungsmöglichkeit

 von B. Berndt

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [5,99 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 sort.vbp ---------------
'-------- Anfang Klasse "clsBBSort" alias bbsort.cls --------

' VB-CONFIGURATION
Option Compare Binary
Option Explicit
Option Base 0

' CONSTANTS(PRIVATE)
Private Const BABERR = vbError + &HBAB
Private Const VAREMPTY = 0&
Private Const NUL& = 0&


' ENUMERATIONS(PUBLIC)
Private Enum TableType_ENUM
    VT_Double
    VT_String
    VT_Long
    VT_Int
End Enum


' VARIABLES(PRIVATE)
Private dblTableDouble()                    As Double
Private strTableString()                    As String
Private lngTableLong()                      As Long
Private objBBparent                         As clsBBSortContainer
Private intTableInt()                       As Integer
Private enmTableType                        As TableType_ENUM
Private enmSort                             As Sort_ENUM
Private lngSortFrom                         As Long
Private lngSortTo                           As Long
Private lngClassID                          As Long
Private lngCount                            As Long


' PROPERTYS(PUBLIC/FRIEND)
Friend Property Let SortFrom(ByVal plngValue As Long)
    lngSortFrom = plngValue
End Property

Friend Property Let SortTo(ByVal plngValue As Long)
    lngSortTo = plngValue
End Property

Friend Property Get Count() As Long
    Count = lngCount
End Property

Friend Property Let ClassID(ByVal plngValue As Long)
    lngClassID = plngValue
End Property

Friend Property Let SortingStyle(ByVal penmSorting As Sort_ENUM)
    enmSort = penmSorting
End Property

Friend Property Get SortingStyle() As Sort_ENUM
    SortingStyle = enmSort
End Property

Friend Property Set BBparent(ByVal objParent As clsBBSortContainer)
    Set objBBparent = objParent
End Property
Friend Property Get BBparent() As clsBBSortContainer
    Set BBparent = objBBparent
End Property


'FUNCTIONS/SUBS
'PUBLIC

Public Sub Clear()
'Auflösen von Zirkelbezügen
    Set objBBparent = Nothing
    
End Sub

Public Sub Go()
    
    Dim OuterCycle              As Long
    Dim InnerCycle              As Long
    Dim CountEqu                As Long
    Dim a                       As Variant
    Dim b                       As Variant
    
    For OuterCycle = lngSortTo - 1 To lngSortFrom Step -1
        For InnerCycle = lngSortFrom To OuterCycle Step 1
            a = GetValue(InnerCycle)
            b = GetValue(InnerCycle + 1)
            Select Case enmSort
                Case Sort_ENUM.S_Ascending:
                    If a > b Then
                        Call Swap(InnerCycle, InnerCycle + 1)
                        Call objBBparent.DoSwapValue(lngClassID, InnerCycle, InnerCycle + 1)
                    End If
                Case Sort_ENUM.S_descending:
                    If a < b Then
                        Call Swap(InnerCycle, InnerCycle + 1)
                        Call objBBparent.DoSwapValue(lngClassID, InnerCycle, InnerCycle + 1)
                    End If
            End Select
        Next InnerCycle
    Next OuterCycle
    
    For OuterCycle = lngSortFrom To lngSortTo - 1 Step 1
        a = GetValue(OuterCycle)
        b = GetValue(OuterCycle + 1)
        If a = b Then
            CountEqu = CountEqu + 1
        Else
            If CountEqu > 0 Then
                Call objBBparent.DoSort(lngClassID, OuterCycle - CountEqu, OuterCycle)
                CountEqu = 0
            End If
        End If
    Next OuterCycle
    If CountEqu > 0 Then
        Call objBBparent.DoSort(lngClassID, lngSortTo - CountEqu, lngSortTo)
    End If

End Sub

Public Sub Swap(ByVal plngFrom As Long, ByVal plngTo)
    
    Dim DeltaDouble             As Double
    Dim DeltaString             As String
    Dim DeltaLong               As Long
    Dim DeltaInt                As Integer
    
    Select Case enmTableType
        Case TableType_ENUM.VT_Double:
            DeltaDouble = dblTableDouble(plngTo)
            dblTableDouble(plngTo) = dblTableDouble(plngFrom)
            dblTableDouble(plngFrom) = DeltaDouble
        Case TableType_ENUM.VT_String:
            DeltaString = strTableString(plngTo)
            strTableString(plngTo) = strTableString(plngFrom)
            strTableString(plngFrom) = DeltaString
        Case TableType_ENUM.VT_Long:
            DeltaLong = lngTableLong(plngTo)
            lngTableLong(plngTo) = lngTableLong(plngFrom)
            lngTableLong(plngFrom) = DeltaLong
        Case TableType_ENUM.VT_Int:
            DeltaInt = intTableInt(plngTo)
            intTableInt(plngTo) = intTableInt(plngFrom)
            intTableInt(plngFrom) = DeltaInt
    End Select
    
End Sub

Friend Sub SetTableDouble(ByRef pdblTable() As Double)
    Dim x                       As Long
    
    ReDim dblTableDouble(0 To UBound(pdblTable))
    For x = 0 To UBound(dblTableDouble)
        dblTableDouble(x) = pdblTable(x)
    Next x
    dblTableDouble() = pdblTable()
    lngCount = UBound(dblTableDouble) + 1
    enmTableType = VT_Double
End Sub
Friend Function GetTableDouble(ByRef pdblTable() As Double) As Long
    Dim x                       As Long
    
    For x = 0 To UBound(pdblTable)
        pdblTable(x) = dblTableDouble(x)
    Next x
    GetTableDouble = x
End Function

Friend Sub SetTableString(ByRef pstrTable() As String)
    Dim x                       As Long
    
    ReDim strTableString(0 To UBound(pstrTable))
    For x = 0 To UBound(strTableString) Step 1
        strTableString(x) = pstrTable(x)
    Next x
    lngCount = UBound(strTableString) + 1
    enmTableType = VT_String
End Sub
Friend Function GetTableString(ByRef pstrTable() As String) As Long
    Dim x                       As Long
    
    For x = 0 To UBound(pstrTable) Step 1
        pstrTable(x) = strTableString(x)
    Next x
    GetTableString = x
End Function

Friend Sub SetTableLong(ByRef plngTable() As Long)
    Dim x                       As Long
    
    ReDim lngTableLong(0 To UBound(plngTable))
    For x = 0 To UBound(lngTableLong) Step 1
        lngTableLong(x) = plngTable(x)
    Next x
    lngCount = UBound(lngTableLong) + 1
    enmTableType = VT_Long
End Sub
Friend Function GetTableLong(ByRef plngTable() As Long) As Long
    Dim x                       As Long
    
    For x = 0 To UBound(plngTable) Step 1
        plngTable(x) = lngTableLong(x)
    Next x
    GetTableLong = x
End Function

Friend Sub SetTableInt(ByRef pintTable() As Integer)
    Dim x                       As Long
    
    ReDim intTableInt(0 To UBound(pintTable()))
    For x = 0 To UBound(intTableInt) Step 1
        intTableInt(x) = pintTable(x)
    Next x

    lngCount = UBound(intTableInt) + 1
    enmTableType = VT_Int
End Sub
Friend Function GetTableInt(ByRef pintTable() As Integer) As Long
    Dim x                       As Long
    
    For x = 0 To UBound(pintTable) Step 1
        pintTable(x) = intTableInt(x)
    Next x
    GetTableInt = x
End Function

Private Sub Class_Terminate()
    Call Clear
End Sub

Private Function GetValue(ByVal plngIndex As Long) As Variant
    Select Case enmTableType
        Case TableType_ENUM.VT_Double:
            GetValue = dblTableDouble(plngIndex)
        Case TableType_ENUM.VT_String:
            GetValue = strTableString(plngIndex)
        Case TableType_ENUM.VT_Long:
            GetValue = lngTableLong(plngIndex)
        Case TableType_ENUM.VT_Int:
            GetValue = intTableInt(plngIndex)
    End Select
    
End Function
'--------- Ende Klasse "clsBBSort" alias bbsort.cls ---------
'--- Anfang Klasse "clsBBSortContainer" alias bbsortcontainer.cls ---

' VB-CONFIGURATION
Option Compare Binary
Option Explicit
Option Base 0


' CONSTANTS(PRIVATE)
Private Const BABERR = vbError + &HBAB
Private Const VAREMPTY = 0&
Private Const NUL& = 0&


' ENUMERATIONS(PUBLIC)
Public Enum Sort_ENUM
    S_Ascending
    S_descending
    S_none
End Enum

Private Enum TableType_ENUM
    VT_Double
    VT_String
    VT_Long
    VT_Int
End Enum


' VARIABLES(PRIVATE)
Private objBBSort()                         As clsBBSort
Private lngCount                            As Long
Private enmSortingStyleAllColumns           As Sort_ENUM


' PROPERTYS(PUBLIC/FRIEND)
Public Property Let SortingStyleAllColumns(ByVal penmSorting As Sort_ENUM)
    Dim x                       As Long
    For x = 0 To lngCount - 1 Step 1
        objBBSort(x).SortingStyle = penmSorting
    Next x
    
End Property
Public Property Get SortingStyleAllColumns() As Sort_ENUM
    SortingStyleAllColumns = enmSortingStyleAllColumns
End Property
Public Property Let SortingStyleColumn(ByVal plngIndex As Long, penmSortingStyle As Sort_ENUM)
    objBBSort(plngIndex).SortingStyle = penmSortingStyle
End Property
Public Property Get SortingStyleColumn(ByVal plngIndex As Long) As Sort_ENUM
    SortingStyleColumn = objBBSort(plngIndex).SortingStyle
End Property

' FUNCTIONS/SUBS
' PUBLIC

Public Sub Clear()
'Auflösen von Zirkelbezügen
    Dim x                       As Long

    For x = 0 To lngCount - 1
        Set objBBSort(x) = Nothing
    Next x
End Sub

Public Sub Go()
    objBBSort(0).SortFrom = 0
    objBBSort(0).SortTo = objBBSort(0).Count - 1
    Call objBBSort(0).Go
End Sub

Public Sub PushDouble(ByRef pdblArray() As Double)
    Call RegisterNewClass
    Call objBBSort(lngCount - 1).SetTableDouble(pdblArray())
End Sub
Public Function PopDouble(ByRef pdblArray() As Double) As Long
    lngCount = lngCount - 1
    PopDouble = objBBSort(lngCount).GetTableDouble(pdblArray())
    Set objBBSort(lngCount) = Nothing
End Function

Public Sub PushString(ByRef pstrArray() As String)
    Call RegisterNewClass
    Call objBBSort(lngCount - 1).SetTableString(pstrArray())
End Sub
Public Function PopString(ByRef pstrArray() As String) As Long
    lngCount = lngCount - 1
    PopString = objBBSort(lngCount).GetTableString(pstrArray())
    Set objBBSort(lngCount) = Nothing
End Function

Public Sub PushLong(ByRef plngArray() As Long)
    Call RegisterNewClass
    Call objBBSort(lngCount - 1).SetTableLong(plngArray())
End Sub
Public Function PopLong(ByRef plngArray() As Long) As Long
    lngCount = lngCount - 1
    PopLong = objBBSort(lngCount).GetTableLong(plngArray())
    Set objBBSort(lngCount) = Nothing
End Function

Public Sub PushInt(ByRef pintArray() As Integer)
    Call RegisterNewClass
    Call objBBSort(lngCount - 1).SetTableInt(pintArray())
End Sub
Public Function PopInt(ByRef pintArray() As Integer) As Long
    lngCount = lngCount - 1
    PopInt = objBBSort(lngCount).GetTableInt(pintArray())
    Set objBBSort(lngCount) = Nothing
End Function

Friend Sub DoSwapValue(ByVal ClassCallerID As Long, ByVal FromPosition As Long, _
    ByVal ToPosition As Long)
    
    Dim x                       As Long
    For x = 0 To lngCount - 1 Step 1
        If ClassCallerID <> x Then
            Call objBBSort(x).Swap(FromPosition, ToPosition)
        End If
    Next x
End Sub

Friend Sub DoSort(ByVal ClassCallerID As Long, ByVal FromPosition As Long, _
    ByVal ToPosition As Long)
    
    If ClassCallerID < lngCount - 1 Then
        objBBSort(ClassCallerID + 1).SortFrom = FromPosition
        objBBSort(ClassCallerID + 1).SortTo = ToPosition
        Call objBBSort(ClassCallerID + 1).Go
    End If
End Sub

' PRIVATE/FRIEND
Private Sub Class_Terminate()
    Call Clear
End Sub

Private Sub RegisterNewClass()
    
    ReDim Preserve objBBSort(0 To lngCount)
    Set objBBSort(lngCount) = New clsBBSort
    Set objBBSort(lngCount).BBparent = Me
        objBBSort(lngCount).ClassID = lngCount
    lngCount = lngCount + 1

End Sub
'--- Ende Klasse "clsBBSortContainer" alias bbsortcontainer.cls ---
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Listen-Steuerelement "List1"

'
'Autor: B.Berndt <bittraveler@gmx.net>

Option Explicit

Private Sub Command1_Click()

    Dim sc As New clsBBSortContainer
    
    Dim a(0 To 100) As Integer
    Dim b(0 To 100) As Double
    Dim x
    
    For x = 0 To 99                         '100 Zufallszahlen im Bereich zwischen
        a(x) = CInt(Math.Rnd(100) * 100)    '0 und 100(incl.)
        b(x) = CDbl(Math.Rnd(100) * 100)
    Next x
    
    Call fillList(Me.List1, a, b)           'Ausgeben der unsortierten Liste
    
    Call sc.PushInt(a)                      'Erste Spalte vom Typ Integer-Array übergeben
    Call sc.PushDouble(b)                   'Zweite Spalte vom Typ Double-Array übergeben
    sc.SortingStyleAllColumns = S_Ascending 'Alle Spalten werden Aufsteigen Sortiert
    sc.Go                                   'nun gehts los
    Call sc.PopDouble(b)                    'Zweite Spalte vom Typ Double-Array holen
    Call sc.PopInt(a)                       'Erste Spalte vom Typ Integer-Array holen
    
    Call fillList(Me.List2, a, b)           'Ausgeben der sortierten Liste
    
    Set sc = Nothing                        'Freigabe der Resourcen
End Sub

Private Sub fillList(ByRef pList As ListBox, ParamArray pArrays() As Variant)
    Dim a() As Integer
    Dim b() As Double
    Dim i
    
    pList.Clear
    
    a = pArrays(0) 'Typisierung nach Integer-Array
    b = pArrays(1) 'Typiesierung nach Double-Array
    For i = 0 To UBound(a)
        Call pList.AddItem(Format(a(i), "00") & "  ;  " & Format$(b(i), "0.00"))
    Next i
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---------------- Ende Projektdatei sort.vbp ----------------