Viele numerische Prozeduren arbeiten auf der Grundlage von Datenmatrizen ( = zweidimensional deklarierte numerische Arrays). Dabei müssen manchmal Teilbereiche von Arrays gelesen, kopiert oder verschoben werden. Üblicherweise programmiert man eine Doppelschleife, die die einzelnen Array-Elemente im benötigten Teilbereich vom Quell-Array in das Ziel-Array überträgt. Bei sehr großen Datenfeldern und sich wiederholenden Kopier-Operationen verbraucht diese Vorgehensweise ordentlich Rechenzeit. Bei den Routinen im Modul 'modTeilmatrix' wird deshalb ein anderer Weg beschritten. Die Position des ersten Elements der Matrix 'a' kann z.B. abgefragt werden durch die undokumentierte VB-Funktion 'VarPtr': Adresse = VarPtr(a(LBound(a, 1), LBound(a, 2))) Die Länge eines einzelnen Array-Elementes hängt vom Datentyp ab: Byte = 1Byte; Integer/Boolean = 2 Byte; Long/Single = 4 Byte; Currency/Double/Date = 8; Byte, Variant = 16 Byte. Damit steht der Anwendung der API-Funktion 'RtlMoveMemory' nichts im Wege. Im Speicher direkt hintereinander stehende Array-Elemente können durch einen einzigen Aufruf kopiert werden. Falls diese zusammenhängenden Bereiche sehr groß sind, wird das Übertragen von Daten erheblich beschleunigt. Damit die Routinen flexibel für verschiedene Datentypen anwendbar sind, werden Quell- und Ziel-Array als Variant-Parameter übergeben (ByRef). Aus diesem Grund kann zur Ermittlung der Speicheradresse die VarPtr-Funktion nicht benutzt werden. Es ist erforderlich, einen Dreifach-Zeiger aufzulösen und die SafeArray-Struktur der Datenfelder zu lesen (vgl. Routine: 'ArrayInfo'). Diese Struktur enthält den benötigten Zeiger und wird zusätzlich herangezogen zur Kontrolle der Array-Dimensionen und der Art der Deklaration. Aufruf der Routine 'TeilMatrix_Lesen': Aufruf der Routine 'TeilMatrix_Schreiben': Beide Routinen melden 'False' wenn der zu lesende bzw. zu schreibende Bereich die Dimensionen der Matrix über- oder unterschreitet (näheres ist dem Quellcode zu entnehmen). Die Routinen akzeptieren auch Arrays, deren Elemente aus dem Datentyp Variant bestehen. Sollten (einzelne oder alle) Elemente im zu kopierenden Bereich nicht-numerisch sein (einschließlich BOOLEAN und DATE), droht ein Programmabsturz. Der Datentyp DECIMAL ist zugelassen, aber auch numerisch interpretierbare Strings sind nicht erlaubt. Die Routine 'Demo_TeilMatrix' zeigt, wie in einer Matrix gelesen und geschrieben wird. ' ================================================================ ' Start Quellcode 'modTeilMatrix' ' ================================================================ Option Explicit ' Lesen und Schreiben einer Teilmatrix ' Die Routinen verarbeiten alle numerischen VB-Datentypen ' Kopierfunktion für eine Bytefolge Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" ( _ Ziel As Any, _ Quelle As Any, _ ByVal Anzahl_Bytes As Long) ' Teil der 'SafeArray'-Struktur eines Datenfeldes Private Type udtArrayInfo Dimensionen As Integer ' Zahl der Dimensionen Features As Integer ' Array-Attribute (als Bitfolge) Bytes_Pro_Feld As Long ' Anzahl der Bytes pro Element Locks As Long ' Anzahl der gesetzten Array-Sperren Data_Pointer As Long ' numerisch: Zeiger auf Array-Start End Type Public Function TeilMatrix_Lesen(ByRef Matrix As Variant, _ ByRef TeilMatrix As Variant, _ ByVal Start1 As Long, _ ByVal Start2 As Long, _ ByVal ZuLesen1 As Long, _ ByVal ZuLesen2 As Long) As Boolean ' In 'Matrix' wird die 'Teilmatrix' ausgelesen ' Start1: 1. zu lesender Index in Matrix (Dim 1) ' ZuLesen1: zu lesende Indices in Dimension 1 ' Start2: 1. zu lesender Index in Matrix (Dim 2) ' ZuLesen2: zu lesende Indices in Dimension 2 Dim quell_ptr As Long, ziel_ptr As Long Dim pos As Long, i As Long, z As Long Dim ai_m As udtArrayInfo, ai_tm As udtArrayInfo Dim lb1 As Long, lb2 As Long Dim ub1 As Long, ub2 As Long On Error GoTo fehler ' Eingabeparameter prüfen If Not IsArray(Matrix) Then Exit Function If Not IsArray(TeilMatrix) Then Exit Function If VarType(Matrix) <> VarType(TeilMatrix) Then Exit Function If ZuLesen1 < 1 Or ZuLesen2 < 1 Then Exit Function If Not ArrayInfo(Matrix, ai_m) Then Exit Function ' 2 Dimensionen sind gefordert If ai_m.Dimensionen <> 2 Then Exit Function ' unterstützter Datentyp If Not CheckDatenTyp(Matrix) Then Exit Function lb1 = LBound(Matrix, 1): ub1 = UBound(Matrix, 1) lb2 = LBound(Matrix, 2): ub2 = UBound(Matrix, 2) ' Bereich innerhalb der Matrix? If Start1 < lb1 Or Start1 + ZuLesen1 - 1 > ub1 Then Exit Function If Start2 < lb2 Or Start2 + ZuLesen2 - 1 > ub2 Then Exit Function ' Ausgabe-Teilmatrix verwendbar? If ArrayInfo(TeilMatrix, ai_tm) Then ' bereits deklariertes Array: ' gesperrt, statisch oder fixiert? With ai_tm If .Locks > 0 Then Exit Function If .Features And &H2 Then Exit Function If .Features And &H10 Then Exit Function End With End If ' Ausgabe-Teilmatrix einrichten ReDim TeilMatrix(1 To ZuLesen1, 1 To ZuLesen2) ' nach REDIM ArrayInfo neu lesen If Not ArrayInfo(TeilMatrix, ai_tm) Then Exit Function ' Erstes zu kopierendes Element (Feld-Reihung) pos = (GetPosition(lb1, ub1, lb2, ub2, Start1, Start2) - 1) If pos < 0 Then Exit Function ' Zeiger auf erstes zu kopierendes Element ' in Quell- und Zielarray quell_ptr = pos * ai_m.Bytes_Pro_Feld + ai_m.Data_Pointer ziel_ptr = ai_tm.Data_Pointer ' Bereich in 2. Dimension durchlaufen z = 0 For i = Start2 To Start2 + ZuLesen2 - 1 z = z + 1 ' Byte-Abschnitt kopieren Call CopyMemory(ByVal ziel_ptr, ByVal quell_ptr, ZuLesen1 * ai_tm.Bytes_Pro_Feld) ' Zeiger um eine Dimension hochsetzen quell_ptr = quell_ptr + _ (ub1 - lb1 + 1) * ai_m.Bytes_Pro_Feld ziel_ptr = ziel_ptr + _ ZuLesen1 * ai_tm.Bytes_Pro_Feld Next i TeilMatrix_Lesen = True fehler: End Function Public Function TeilMatrix_Schreiben(ByRef Matrix As Variant, _ ByRef TeilMatrix As Variant, _ ByVal Start1 As Long, _ ByVal Start2 As Long) As Boolean ' In 'Matrix' wird die 'Teilmatrix' eingetragen ' Start1: 1. zu beschreibender Index in Matrix (Dim1) ' Start2: 1. zu beschreibender Index in Matrix (Dim2) Dim quell_ptr As Long, ziel_ptr As Long Dim pos As Long, i As Long, z As Long Dim ai_m As udtArrayInfo, ai_tm As udtArrayInfo Dim lb1 As Long, lb2 As Long Dim ub1 As Long, ub2 As Long Dim ZuSchreiben1 As Long, ZuSchreiben2 As Long On Error GoTo fehler ' Eingabeparameter prüfen If Not IsArray(Matrix) Then Exit Function If Not IsArray(TeilMatrix) Then Exit Function If VarType(Matrix) <> VarType(TeilMatrix) Then Exit Function If Not CheckDatenTyp(Matrix) Then Exit Function ' Array deklariert (SafeArray verfügbar)? If Not ArrayInfo(Matrix, ai_m) Then Exit Function ' 2 Dimensionen sind gefordert If ai_m.Dimensionen <> 2 Then Exit Function lb1 = LBound(Matrix, 1): ub1 = UBound(Matrix, 1) lb2 = LBound(Matrix, 2): ub2 = UBound(Matrix, 2) ' Teilmatrix verwendbar? If Not ArrayInfo(TeilMatrix, ai_tm) Then Exit Function If ai_tm.Dimensionen <> 2 Then Exit Function ZuSchreiben1 = UBound(TeilMatrix, 1) - LBound(TeilMatrix, 1) + 1 ZuSchreiben2 = UBound(TeilMatrix, 2) - LBound(TeilMatrix, 2) + 1 ' Kann Teilmatrix vollständig eingefügt werden? If Start1 < lb1 Or Start1 + ZuSchreiben1 - 1 > ub1 Or _ Start2 < lb2 Or Start2 + ZuSchreiben2 - 1 > ub2 Then Exit Function End If ' Position des ersten zu kopierenden Elements in Zielmatrix ' (Feld-Reihung) pos = (GetPosition(lb1, ub1, lb2, ub2, Start1, Start2) - 1) If pos < 0 Then Exit Function ' Zeiger auf erstes einzufügendes Element ' in Quell- und Zielarray quell_ptr = pos * ai_m.Bytes_Pro_Feld + ai_m.Data_Pointer ziel_ptr = ai_tm.Data_Pointer ' Bereich in 2. Dimension durchlaufen z = 0 For i = Start2 To Start2 + ZuSchreiben2 - 1 z = z + 1 ' Byte-Abschnitt kopieren Call CopyMemory(ByVal quell_ptr, ByVal ziel_ptr, ZuSchreiben1 * ai_tm.Bytes_Pro_Feld) ' Zeiger um eine Dimension hochsetzen quell_ptr = quell_ptr + (ub1 - lb1 + 1) * ai_m.Bytes_Pro_Feld ziel_ptr = ziel_ptr + ZuSchreiben1 * ai_tm.Bytes_Pro_Feld Next i TeilMatrix_Schreiben = True fehler: End Function Private Function CheckDatenTyp(ByRef Matrix As Variant) As Boolean ' Datentyp der Matrix prüfen Dim vt As Long, ok As Boolean vt = VarType(Matrix) - vbArray If vt = vbByte Then ok = True If vt = vbInteger Or vt = vbLong Then ok = True If vt = vbSingle Or vt = vbDouble Then ok = True If vt = vbCurrency Then ok = True If vt = vbBoolean Or vt = vbDate Then ok = True If vt = vbVariant Then ok = True CheckDatenTyp = ok End Function Private Function GetPosition(ByVal lb1 As Long, ByVal ub1 As Long, _ ByVal lb2 As Long, ByVal ub2 As Long, _ ByVal pos1 As Long, ByVal pos2 As Long) As Long ' absolute Position eines Datenfeldes in einem Array GetPosition = -1 If pos1 < lb1 Or pos1 > ub1 Then Exit Function If pos2 < lb2 Or pos2 > ub2 Then Exit Function GetPosition = ((ub1 - lb1) + 1) * (pos2 - lb2) + (pos1 - lb1 + 1) End Function Private Function ArrayInfo(ByRef Matrix As Variant, ai As udtArrayInfo) As Boolean ' Arrayinfos abfragen Dim vtp As Long, ptr As Long If Not IsArray(Matrix) Then Exit Function ' (Array ist über einen Variant-Parameter ' ByRef' übergeben worden) Call CopyMemory(vtp, ByVal VarPtr(Matrix) + 8, 4) If vtp = 0 Then Exit Function Call CopyMemory(ptr, ByVal vtp, 4&) If ptr = 0 Then Exit Function Call CopyMemory(ai, ByVal ptr, 16) ArrayInfo = True End Function Public Function Demo_TeilMatrix() As Boolean ' Demonstration Lesen/Schreiben einer Teilmatrix Dim ug1&, og1&, ug2&, og2& ' Matrix-Dim Dim i&, k&, i1&, k1&, du& ' Loops Dim bug1&, bog1&, bug2&, bog2& ' Bereich Dim Matrix() As Variant, TeilMatrix() As Variant ' Testdurchgänge For du = 1 To 1000 ' zufällige Dimensionen og1 = Rnd * 200 + 1 og2 = Rnd * 200 + 1 ug1 = Rnd * (og1 - 1) + 1 ug2 = Rnd * (og2 - 1) + 1 ' Matrix erstellen ReDim Matrix(ug1 To og1, ug2 To og2) ' Matrix füllen For i = ug1 To og1 For k = ug2 To og2 ' wechselnde Datentypen in ' Variant-Array eintragen If du Mod 5 = 1 Then Matrix(i, k) = CByte(Rnd * 250 + 1) ElseIf du Mod 5 = 2 Then Matrix(i, k) = CDec(Rnd * 1000000) ElseIf du Mod 5 = 3 Then Matrix(i, k) = CCur(Rnd * 1000000) ElseIf du Mod 5 = 4 Then Matrix(i, k) = CDate(Rnd * 10000) Else Matrix(i, k) = CSng(Rnd * 1000000) End If Next k Next i ' zu lesender Bereich per Zufall bog1 = Rnd * (og1 - ug1) + ug1 bug1 = Rnd * (bog1 - ug1) + ug1 bog2 = Rnd * (og2 - ug2) + ug2 bug2 = Rnd * (bog2 - ug2) + ug2 ' Bereich Lesen If Not TeilMatrix_Lesen(Matrix(), TeilMatrix(), bug1, bug2, bog1 - bug1 + 1, _ bog2 - bug2 + 1) Then MsgBox "Lesevorgang scheitert!" Exit Function End If ' Vergleichen: Matrix-Bereich / Teilmatrix i1 = 0 For i = bug1 To bog1 i1 = i1 + 1: k1 = 0 For k = bug2 To bog2 k1 = k1 + 1 If Matrix(i, k) <> TeilMatrix(i1, k1) Then MsgBox "Lesevorgang fehlerhaft" Exit Function End If ' Bereich in Matrix auf 0 setzen Matrix(i, k) = 0 Next k Next i ' Teilmatrix wieder in Matrix eintragen If Not TeilMatrix_Schreiben(Matrix(), TeilMatrix(), bug1, bug2) Then MsgBox "Schreibvorgang scheitert!" Exit Function End If ' Vergleichen: Matrix-Bereich / Teilmatrix i1 = 0 For i = bug1 To bog1 i1 = i1 + 1: k1 = 0 For k = bug2 To bog2 k1 = k1 + 1 If Matrix(i, k) <> TeilMatrix(i1, k1) Then MsgBox "Schreibvorgang fehlerhaft" Exit Function End If Next k Next i Next du ' nächster Durchgang MsgBox "Test beendet" Demo_TeilMatrix = True End Function ' ================================================================ ' Start Quellcode 'modTeilMatrix' ' ================================================================ Dieser Tipp wurde bereits 10.504 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. |
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 März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevEingabe 3.0 Einfach stark! Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox 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. |