Sortieren von Arrays aus Strings fester Länge Sortieren von Arrays, deren Elemente aus Strings fester Länge bestehen
Autor:   Manfred Bohn	Bewertung:     [ Jetzt bewerten ]	Views:  13.507
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 6 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.3 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Die üblichen Sortier-Routinen für String-Arrays beziehen sich gewöhnlich nur auf Strings variabler Länge. Soweit diese Prozeduren 'optimiert' sind, lassen sie sich nicht auf Arrays aus Strings fester Länge übertragen, weil diese VB-intern völlig anders verwaltet werden.

Auf Strings variabler Länge wird zugegriffen durch einen festen Zeiger auf einen dynamischen Zeiger, der auf den String zeigt. Ändert man den String, erzeugt VB normalerweise einen neuen String an einer anderen Speicherstelle und modifiziert den dynamischen Zeiger entsprechend.

Strings fester Länge sind im Speicher unmittelbar hintereinander aufgereiht und wechseln ihre Position nie. Bei Veränderung des Inhalts eines Array-Elements ändert sich der benötigte Speicherbereich nicht, weil die eingetragene Information entweder mit 'Blanks' aufgefüllt oder abgeschnitten wird.

Es ist relativ einfach, eine Sortierroutine zu programmieren, die Strings einer bestimmten festen Länge sortiert, wenn man aber mehrere Arrays hat, die unterschiedliche feste Längen aufweisen, wird die Angelegenheit etwas komplizierter.
Das beginnt schon damit, dass es nicht möglich ist, ein Array aus Strings fester Länge auf einen Variant-Parameter in einer Prozedurdeklaration zuzuweisen: 'Argument unverträglich!'.
Eine Funktion, die alle eindimensionalen Arrays aus Strings fester Länge sortieren soll, muss deshalb mit Zeigern arbeiten.

Den Zeiger auf ein Array erhält man über die undokumentierte VB-Funktion 'VarPtr'. Die kann man allerdings bei Datenfeldern nicht direkt aufrufen, sondern man muss sich mit einer DECLARE-Anweisung behelfen (vgl. Modul 'modSort_StringFix').

Die Routine 'Sort_StringFix' liest die SafeArray-Struktur des zugehörigen Datenfeldes und ermittelt daraus die Start-Position im Speicher (Data_Pointer), die fixe Länge der Strings (UNICODE: doppelte Byteanzahl) und die Zahl der Elemente (=Strings) im Array. Die Untergrenze der Deklaration des Array bleibt unbeachtet, weil direkt über die Speicher-Adressen auf die Strings zugegriffen wird.

Die Routine bietet die Wahl zwischen dem Heapsort- und dem Quicksort-Algorithmus.
Da der rekursive Quicksort sich unter ungünstigen Umständen bei großen Arrays als 'Stapelfresser' erweisen kann und dabei extrem langsam wird (sogar bis zum Fehler wegen Überlauf des Stapelspeichers) wird ein zufälliger Aufteilungs-Schlüssel verwendet und die Rekursionstiefe überwacht.

Die Routine kann nur zum Sortieren von eindimensionalen Arrays aus Strings fester Länge verwendet werden! Das Array kann dynamisch (REDIM) oder statisch (DIM) deklariert sein. ('Sort_StringFix' benötigt zum Sortieren von 100000 Strings der Länge 20 weniger als eine Zehntelsekunde und kann noch optimiert werden.)

Die Prozedur 'Demo_Sort_StringFix' demonstriert die Anwendung.

' ==================================================================
' Start Quellcode Modul 'modSort_StringFix'
' ==================================================================
Option Explicit
 
' VarPtr-Funktionsaufruf für Arrays
Public Declare Function VarPtrArray Lib "msvbvm60.dll" _
  Alias "VarPtr" ( _
  Ptr() As Any) As Long
 
' schnelle API-Kopierfunktion für Bytefolgen
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  Ziel As Any, _
  Quelle As Any, _
  ByVal Anzahl_Bytes As Long)
 
' SafeArray-Struktur (eindimensionales Array)
Private Type udtArrayInfo
  Dimensionen As Integer     ' Zahl der Dimensionen
  Features As Integer        ' Attribute (Bitfolge)
  Bytes_pro_Feld As Long     ' Anzahl der Bytes pro Element
  Locks As Long              ' Anzahl der gesetzten Array-Sperren
  Data_Pointer As Long       ' bei Strings: Varptr --> Deskriptor
  Elemente As Long           ' Elemente im Array
  Untergrenze As Long        ' Untergrenze der Dimension
End Type

Public Function Sort_StringFix(ByRef pArray As Long, _
  Optional ByVal Version As Long = 1)
 
  ' Sortieren eines Array aus Strings fester Länge
  ' Übergabe des Zeigers auf das Array erforderlich!
  ' aufrufen durch:  VarPtrArray(StringArray())
 
  Dim SafeArray As udtArrayInfo
 
  ' SafeArray-Struktur abfragen
  If Not GetSafeArray(pArray, SafeArray) Then Exit Function
 
  With SafeArray
    If Version = 1 Then
      Sort_StringFix = HeapSort_StringF _
        (.Data_Pointer, .Bytes_pro_Feld, 1, .Elemente)
    ElseIf Version = 2 Then
      Sort_StringFix = QuickSort_StringF _
        (.Data_Pointer, .Bytes_pro_Feld, 1, .Elemente)
    Else
      Sort_StringFix = SimpleSort _
      (.Data_Pointer, .Bytes_pro_Feld, .Elemente)
    End If
  End With
End Function

Private Function GetSafeArray(ByRef pArray As Long, _
  SafeArray As udtArrayInfo) As Boolean
 
  Dim ptrS As Long, iDim As Long
 
  ' Array gegeben
  If pArray = 0 Then Exit Function
 
  ' Adresse des Array-Info-Block besorgen
  Call CopyMemory(ptrS, ByVal pArray, 4&)
 
  ' Array dimensioniert?
  If ptrS = 0 Then Exit Function
 
  ' Zahl der Dimensionen des Array besorgen
  Call CopyMemory(iDim, ByVal ptrS, 2&)
  If iDim <> 1 Then
    ' unplausible Anzahl Dimensionen!
    Exit Function
  End If
 
  ' SafeArray in den Array-Info-Block kopieren
  Call CopyMemory(SafeArray, ByVal ptrS, 24)
 
  With SafeArray
    GetSafeArray = .Data_Pointer > 0 And .Bytes_pro_Feld > 0
  End With
End Function

Public Function GetStringFixFromPointer(ByVal Pointer As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal index As Long) As String
 
  ' Die Routine besorgt einen VB-String fester Länge am 'Index'
  ' aus einem Array das ab der Position 'Pointer' steht
  ' (Funktion auch für Windows98 geeignet)
 
  Dim str As String, iPtr As Long
 
  If Pointer <= 0 Or Bytes_pro_Feld < 2 Then Exit Function
  If index < 1 Then Exit Function
 
  iPtr = Pointer + Bytes_pro_Feld * (index - 1)
 
  ' Die halbe Länge ist VB-intern die ganze Länge!!
  str = String(Bytes_pro_Feld \ 2, " ")
  ' String in 'str' kopieren
  Call CopyMemory(ByVal StrPtr(str), ByVal iPtr, Bytes_pro_Feld)
 
  ' Rückgabe
  GetStringFixFromPointer = str
End Function

Public Function SetStringFixToPointer(ByVal Pointer As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal index As Long, _
  ByVal str As String) As Boolean
 
  ' Die Routine trägt einen VB-String fester Länge am 'Index'
  ' in ein Array ein, das ab der Position 'Pointer' steht
  ' (Funktion auch für Windows98 geeignet)
 
  Dim iPtr As Long
 
  If Pointer <= 0 Or Bytes_pro_Feld < 2 Or index < 1 Then Exit Function
 
  ' Position des Strings berechnen
  iPtr = Pointer + Bytes_pro_Feld * (index - 1)
 
  ' Die halbe Länge ist VB-intern die ganze Länge!!
  While Len(str) < Bytes_pro_Feld \ 2
    str = str + " "
  Wend
 
  ' zu langen String unbedingt kürzen!
  str = Left(str, Bytes_pro_Feld \ 2)
 
  ' String in das Array eintragen
  Call CopyMemory(ByVal iPtr, ByVal StrPtr(str), Bytes_pro_Feld)
 
  ' Rückgabe
  SetStringFixToPointer = True
End Function

Private Function CompareStringFix(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal Index1 As Long, _
  ByVal Index2 As Long) As Long
 
  ' Die Funktion vergleicht zwei Strings fester Länge, die
  ' in zwei Indices eines Array eingetragen sind
 
  ' Rückgabe (analog StrComp/vbTextcompare)
 
  ' -1        Der erste String steht in der Sortier-Reihung des
  '           Gebietsschemas vor dem zweiten
  ' 0         Strings sind gleich
  ' 1         Der zweite steht vor dem ersten
 
  Dim str1 As String, str2 As String
 
  str1 = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, Index1)
  str2 = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, Index2)
 
  CompareStringFix = StrComp(str1, str2, vbTextCompare)
End Function

Private Function CompareStringKey(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal key As String, _
  ByVal index As Long) As Long
 
  ' Die Funktion vergleicht zwei Strings fester Länge
  ' Schlüsselstring 'Key' wird verglichen mit dem
  ' String im 'Index' eines Array
 
  ' Rückgabe (analog StrComp/vbTextcompare)
 
  ' -1        Der erste String steht in der Sortier-Reihung des
  '           Gebietsschemas vor dem zweiten
  ' 0         Strings sind gleich
  ' 1         Der zweite steht vor dem ersten
 
  Dim str As String
  str = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, index)
  CompareStringKey = StrComp(key, str, vbTextCompare)
End Function

Private Function SwapStringFix(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal Index1 As Long, _
  ByVal Index2 As Long) As Boolean
 
  ' Die Funktion vertauscht zwei Strings fester Länge, die
  ' in zwei Indices eines Array eingetragen sind
 
  Dim str1 As String, str2 As String
 
  If Index1 < 1 Or Index2 < 1 Then Exit Function
 
  ' Strings lesen
  str1 = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, Index1)
  str2 = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, Index2)
 
  ' Strings tauschen
  If Not SetStringFixToPointer(Daten_Zeiger, Bytes_pro_Feld, _
    Index2, str1) Then Exit Function
 
  If Not SetStringFixToPointer(Daten_Zeiger, Bytes_pro_Feld, _
    Index1, str2) Then Exit Function
 
  SwapStringFix = True
End Function

Public Function HeapSort_StringF(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal Untergrenze As Long, _
  ByVal Obergrenze As Long) As Boolean
 
  ' Daten werden ansteigend sortiert
  ' eindimensionales Array aus Strings fester Länge
  ' einfacher HeapSort-Algorithmus
 
  Dim i As Long, anz As Long          ' Loop
  anz = Obergrenze - Untergrenze + 1
  If anz = 1 Then
    HeapSort_StringF = True
    Exit Function
  End If
 
  For i = anz \ 2 To 1 Step -1
    If Not iHeapSort_StringF(Daten_Zeiger, Bytes_pro_Feld, i, anz) Then
      Exit Function
    End If
  Next i
 
  Do
    SwapStringFix Daten_Zeiger, Bytes_pro_Feld, 1, anz
    anz = anz - 1
    If Not iHeapSort_StringF(Daten_Zeiger, Bytes_pro_Feld, 1, anz) Then
      Exit Function
    End If
  Loop Until anz <= 1
 
  HeapSort_StringF = True
 
fehler:
End Function

Private Function iHeapSort_StringF(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal start As Long, _
  ByVal Ende As Long) As Boolean
 
  ' Hilfsfunktion: HeapSort (Arrays mit Strings fester Länge)
 
  Dim k As Long, j As Long
  Dim t As String
 
  On Error GoTo fehler
 
  k = start
  t = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, start)
 
  Do While k <= Ende \ 2
    j = k + k
    If j < Ende Then
      If CompareStringFix(Daten_Zeiger, Bytes_pro_Feld, j, j + 1) < 0 Then
        j = j + 1
      End If
    End If
 
    If CompareStringKey(Daten_Zeiger, Bytes_pro_Feld, t, j) >= 0 Then Exit Do
 
    SetStringFixToPointer Daten_Zeiger, Bytes_pro_Feld, k, _
    GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, j)
    k = j
  Loop
 
  SetStringFixToPointer Daten_Zeiger, Bytes_pro_Feld, k, t
  iHeapSort_StringF = True
 
fehler:
End Function

Private Function QuickSort_StringF(ByVal Daten_Zeiger As Long, _
  ByVal Bytes_pro_Feld As Long, _
  ByVal lngStart As Long, _
  ByVal lngEnd As Long) As Boolean
 
  ' rekursiver Quicksort für Array aus Strings fester Länge
  ' Rekursionstiefen-Überwachung und Zufalls-Schlüssel
 
  Dim i As Long, j As Long    ' Loop
  Dim key As String           ' Schlüsselstring
  Dim ind As Long             ' Schlüsselindex
 
  Static gTiefe As Long
 
  ' Rekursionstiefe überschritten?
  If gTiefe > 200 Then Exit Function
  ' neue Rekursion startet
  gTiefe = gTiefe + 1
 
  i = lngStart: j = lngEnd
 
  ' Zufälliger Schlüssel
  ind = Rnd * (lngEnd - lngStart) + lngStart
  key = GetStringFixFromPointer(Daten_Zeiger, Bytes_pro_Feld, ind)
 
  ' Array aufteilen
  Do
    While CompareStringKey(Daten_Zeiger, Bytes_pro_Feld, key, i) > 0
      i = i + 1
    Wend
 
    While CompareStringKey(Daten_Zeiger, Bytes_pro_Feld, key, j) < 0
      j = j - 1
    Wend
 
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      SwapStringFix Daten_Zeiger, Bytes_pro_Feld, i, j
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
 
  ' Rekursive Quicksort-Aufrufe
  If (lngStart < j) Then
    If Not QuickSort_StringF(Daten_Zeiger, Bytes_pro_Feld, lngStart, j) Then
      gTiefe = 0
      Exit Function
    End If
  End If
 
  If (i < lngEnd) Then
    If Not QuickSort_StringF(Daten_Zeiger, Bytes_pro_Feld, i, lngEnd) Then
      gTiefe = 0
      Exit Function
    End If
  End If
 
  gTiefe = gTiefe - 1
  QuickSort_StringF = True
End Function

Private Function SimpleSort(ByVal Daten_Zeiger As Long, _
  Bytes_pro_Feld As Long, _
  ByVal Elemente As Long) As Boolean
 
  ' Primitive Sortierfunktion (nur für Demo)
  Dim i As Long, k As Long
 
  For i = 1 To Elemente
    For k = i + 1 To Elemente
      If CompareStringFix(Daten_Zeiger, Bytes_pro_Feld, i, k) > 0 Then
        If Not SwapStringFix(Daten_Zeiger, Bytes_pro_Feld, i, k) Then
           Exit Function
         End If
       End If
    Next k
  Next i
 
  SimpleSort = True
End Function
' ==================================================================
' Ende Quellcode Modul 'modSort_StringFix'
' ==================================================================

' ====================================================================
' Start Quellcode 'Demo_Sort_StringFix'
' ====================================================================
 
Sub Demo_Sort_StringFix()
  ' Demonstration zum Modul 'modSort_StringFix'
 
  Dim i As Long                    ' Loop
 
  ' dynamisch deklariertes Array
  Dim arr_dyn() As String * 20
  ReDim arr_dyn(-1000 To 1000)
 
  ' fest deklariertes Array
  Dim arr_fix(101 To 1100) As String * 30
 
  ' Arrays mit zufälligen Strings füllen
  For i = LBound(arr_dyn) To UBound(arr_dyn)
    arr_dyn(i) = GetRandomString(20)
  Next i
 
  For i = LBound(arr_fix) To UBound(arr_fix)
    arr_fix(i) = GetRandomString(30)
  Next i
 
  ' Heapsort: dynamisch deklariertes Array
  If Not Sort_StringFix(VarPtrArray(arr_dyn)) Then
    MsgBox "Sortieren scheitert (dyn)"
    Exit Sub
  End If
 
  ' Heapsort testen
  For i = LBound(arr_dyn) To UBound(arr_dyn) - 1
    If StrComp(arr_dyn(i), arr_dyn(i + 1), vbTextCompare) > 0 Then
      MsgBox "Sortieren fehlerhaft (dyn)"
      Exit Sub
    End If
  Next i
 
  ' Quicksort: statisch deklariertes Array
  If Not Sort_StringFix(VarPtrArray(arr_fix), 2) Then
    MsgBox "Sortieren scheitert (fix)"
    Exit Sub
  End If
 
  ' Quicksort testen
  For i = LBound(arr_fix) To UBound(arr_fix) - 1
    If StrComp(arr_fix(i), arr_fix(i + 1), vbTextCompare) > 0 Then
      MsgBox "Sortieren fehlerhaft (fix)"
      Exit Sub
    End If
  Next i
 
  MsgBox "Test erfolgreich abgeschlossen"
End Sub

Function GetRandomString(ByVal Länge As Long) As String
  Dim i As Long, str As String
 
  If Länge < 1 Then Exit Function
  str = String(Länge, " ")
  For i = 1 To Länge
    Mid$(str, i, 1) = Chr$(Rnd * 25 + 65)
  Next i
  GetRandomString = str
End Function
 
' ====================================================================
' Ende Quellcode 'Demo_Sort_StringFix'
' ====================================================================