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. 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. 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' ' ==================================================================== Dieser Tipp wurde bereits 13.509 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 sevOutBar 4.0 Vertikale Menüleisten á la Outlook Erstellen von Outlook ähnlichen Benutzer- interfaces - mit beliebig vielen Gruppen und Symboleinträgen. Moderner OfficeXP-Style mit Farbverläufen, Balloon-Tips, u.v.m. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |