Der nachfolgende Source-Code ist urheberrechtlich geschützt:
Copyright vbArchiv.de - Präsentation durch: Ralph Steinkönig

 
Private scoll As New Collection 'temporäre Collection
Private qcoll As New Collection 'temporäre Collection
Private tmpqcoll As New Collection 'eigentlich Quell-Collection
Private clst As clsco 'Instanz auf die Klasse clsco (späte Bindung)

 
Private Sub TestCollection()
   Set clst = New clsco
   clst.b = 10
   clst.x = 1200
   clst.y = 2200
   qcoll.Add clst
   Set clst = New clsco
   clst.b = 17
   clst.x = 900
   clst.y = 2000
   qcoll.Add clst
   Set clst = New clsco
   clst.b = 9
   clst.x = 3000
   clst.y = 4000
   qcoll.Add clst
   Set clst = New clsco
   clst.b = 20
   clst.x = 3200
   clst.y = 1200
   qcoll.Add clst
   Set clst = New clsco
   clst.b = 9
   clst.x = 900
   clst.y = 600
   qcoll.Add clst
End Sub

 
Private Sub SortCollection()
   Dim myc As clsco
   Dim a As Variant, b As Variant
   Dim m As Long
   'initialisierung von qcoll
   scoll.Add "0"
   'initialisierung von tmpqcoll
   Set myc = New clsco
   With myc
     .b = 0
     .x = 0
     .y = 0
   End With
   tmpqcoll.Add myc
   'Durchlaufen der Quell-Collection
   For Each myc In qcoll
     'Binäre Zuweisung (Hex-Format)
     a = Hex(myc.b) + Hex(myc.x) + Hex(myc.y)
     For Each b In scoll
        If CLng("&H" + a) > b Then m = m + 1
     Next
     scoll.Add CLng("&h" + a), After:=m
     tmpqcoll.Add myc, After:=m
     m = 0
   Next
   tmpqcoll.Remove 1
   Set qcoll = tmpqcoll
   Set scoll = Nothing
   Set tmpqcoll = Nothing
End Sub