Im Tipp Das Modul 'Sort_StringF' enthält eine Version, die weniger als die Hälfte der Zeit benötigt:
Im Vergleich zu Routinen, die Arrays aus Strings mit einer bestimmten festen Länge sortieren, - die also auf Zeiger-Operationen verzichten können - , benötigt auch die Routine 'Sort_StringF' noch mehr als die doppelte Zeit. Zum Aufruf: vgl. Tipp: ' ================================================================== ' Start Quellcode Modul 'modSort_StringF' ' ================================================================== 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 ' Array-Informationen modulglobal Dim gDaten_Zeiger As Long ' Zeiger auf Startposition des Array Dim gString_Länge As Long ' Byte-Länge der Array-Strings Dim gArray_Elemente As Long ' Zahl der Array-Elemente ' Sortier-Strings als Bytefolgen (modulglobal) Dim gStringByte() As Byte ' für Vergleich und Tausch Dim gKeyByte() As Byte ' Schlüsselstring ' Array mit Zeigern auf String-Positionen Dim gStringPos() As Long ' Überwachung der Rekursionstiefe Dim gRekursionsTiefe As Long Public Function Sort_StringF(ByVal pArray As Long) ' Sortieren eines Array aus Strings fester Länge ' Übergabe des Zeigers auf das Array erforderlich! ' aufrufen durch: VarPtrArray(StringArray()) Dim SafeArray As udtArrayInfo Dim i As Long, z As Long ' Loop ' SafeArray-Struktur abfragen If Not GetSafeArray(pArray, SafeArray) Then Exit Function ' ArrayInfos in modulglobale Variable With SafeArray gDaten_Zeiger = .Data_Pointer gString_Länge = .Bytes_pro_Feld gArray_Elemente = .Elemente End With ' ByteArrays einrichten ReDim gStringByte(1 To gString_Länge) ReDim gKeyByte(1 To gString_Länge) ' ZeigerArray einrichten und füllen ReDim gStringPos(1 To gArray_Elemente) z = gDaten_Zeiger For i = 1 To gArray_Elemente gStringPos(i) = z z = z + gString_Länge Next i ' Initialisieren gRekursionsTiefe = 0 ' Sortieren Sort_StringF = QuickSort_StringF(1, gArray_Elemente) End Function Public Function GetSafeArray(ByRef pArray As Long, _ SafeArray As udtArrayInfo) As Boolean ' Safe-Array-Struktur abfragen Dim ptrS As Long, iDim As Long ' Array gegeben If pArray = 0 Then Exit Function ' Adresse des Array-Info-Blocks 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, CLng(16 + iDim * 8)) With SafeArray GetSafeArray = .Data_Pointer > 0 And _ .Bytes_pro_Feld > 1 And .Elemente > 0 End With End Function Private Function CompareStringKeyF(ByVal Index As Long) As Long ' String fester Länge an Array-Index 'index' ' mit Keystring (Bytefolge) vergleichen (in 'gKeyByte') Dim Ptr As Long If Index < 1 Or Index > gArray_Elemente Then Exit Function ' String am 'Index' als Bytefolge besorgen Call CopyMemory(gStringByte(1), ByVal gStringPos(Index), gString_Länge) ' String mit Key-String vergleichen CompareStringKeyF = StrComp(gKeyByte(), gStringByte(), vbTextCompare) End Function Private Function QuickSort_StringF(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 ptri As Long, ptrj As Long ' Zeiger aud Array-Elemente i, j Dim IndKey As Long ' Array-Index Schlüsselstring ' Rekursionstiefe überschritten? If gRekursionsTiefe > 200 Then Exit Function ' neue Rekursion startet gRekursionsTiefe = gRekursionsTiefe + 1 ' zu sortierender Bereich i = lngStart: j = lngEnd ' Zufälliger Schlüssel: modulglobal speichern IndKey = Rnd * (lngEnd - lngStart) + lngStart Call CopyMemory(gKeyByte(1), ByVal gStringPos(IndKey), gString_Länge) ' Array aufteilen Do While CompareStringKeyF(i) > 0 i = i + 1 Wend While CompareStringKeyF(j) < 0 j = j - 1 Wend If (i <= j) Then ' Tauschen j <--> i Call CopyMemory(gStringByte(1), ByVal gStringPos(i), gString_Länge) Call CopyMemory(ByVal gStringPos(i), ByVal gStringPos(j), gString_Länge) Call CopyMemory(ByVal gStringPos(j), gStringByte(1), gString_Länge) i = i + 1: j = j - 1 End If Loop Until (i > j) ' Rekursive Quicksort-Aufrufe If (lngStart < j) Then If Not QuickSort_StringF(lngStart, j) Then Exit Function End If If (i < lngEnd) Then If Not QuickSort_StringF(i, lngEnd) Then Exit Function End If ' Rekursionstiefe am Routinenende verringern gRekursionsTiefe = gRekursionsTiefe - 1 QuickSort_StringF = True End Function ' ================================================================== ' Ende Quellcode Modul 'modSort_StringF' ' ================================================================== Dieser Tipp wurde bereits 11.336 mal aufgerufen.
Anzeige
![]() ![]() ![]() 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. |
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. Tipp des Monats ![]() Dieter Otter Beliebige Zeichen am Anfang und Ende eines Strings entfernen Mit der Trim-Funktion lassen sich nicht nur Leerzeichen, sondern bei Bedarf auch beliebige Zeichen entfernen. Access-Tools Vol.1 ![]() Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |