Im Tipp Sortieren von Arrays aus Strings fester Länge ist gezeigt worden, auf welche Weise man Funktionen erstellen kann, die Arrays aus Strings fester, aber beliebiger Länge bearbeiten können. Weil diese Routinen zum Zweck der Demonstration erstellt worden sind, ist auf die Optimierung der Sortiergeschwindigkeit verzichtet worden. 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: Sortieren von Arrays aus Strings fester Länge ' ================================================================== ' 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.266 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 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. |
Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung 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. |