Erweiterung von REDIM PRESERVE Re-Dimensionierung einer Datenmatrix unter Beibehaltung des Inhalts
Autor:   Manfred Bohn	Bewertung:     [ Jetzt bewerten ]	Views:  18.497
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	kein Beispielprojekt

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

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Mit dem Schlüsselwort PRESERVE kann man dynamisch deklarierte Arrays neu dimensionieren und dabei den Inhalt ganz oder teilweise beibehalten. Dem sind aber enge Grenzen gesetzt: Nur die obere Grenze der letzten (bei einer Matrix: zweiten) Dimension kann geändert werden. Zudem ist PRESERVE nicht besonders effizient. Falls bei einer Vergrößerung der letzten Dimension nicht zufällig der erforderliche Speicherplatz 'hinter dem Array' frei ist, wird eine umfangreiche Restrukturierung des Speichers fällig. Es wird deshalb stets strikt davon abgeraten, z.B. bei Bearbeitung einer Programm-Schleife sukzessive die Array-Dimension um ein Element zu erhöhen. Statt dessen ist beim Erreichen der Grenze immer eine Vergrößerung um 100 oder sogar 1000 Elemente zweckmäßig, damit die Anzahl der REDIM-PRESERVE-Operationen sich in Grenzen hält.

Die Funktion 'REDIM_MATRIX' erlaubt die Veränderung aller Array-Grenzen (unten und oben) bei numerischen Datenmatrizen. Der Matrix-Inhalt kann dabei an eine beliebige Position verschoben werden. Welche Datentypen von 'REDIM_MATRIX' unterstützt werden, ist der Funktion 'GetTypeLeng' zu entnehmen.

Zur effizienten Daten-Übertragung wird die API-Kopierfunktion 'RtlMoveMemory' verwendet, wie es bereits im Tipp  Teilmatrix lesen und schreiben gezeigt worden ist. Allerdings muß bei der Funktion 'REDIM_MATRIX' auf eine Variante zurückgegriffen werden, um die verschiedenen Datentypen der Eingabematrix 'intern' bearbeiten zu können (= Zwischenspeicherung in einem dreidimensionalen Byte-Array). Die beiden Funktionen 'TeilmatrixB_Lesen' und 'TeilmatrixB_Schreiben' sind allgemein verwendbar zum Datentransport bei der Entwicklung von Funktionen, die Arrays unterschiedlicher Datentypen verarbeiten sollen (und die deshalb über einen Variant-Parameter zugewiesen werden).

Beschreibung der Argumente der Funktion 'REDIM_MATRIX':
Der Variant-Parameter 'Matrix' erwartet eine zweidimensionale Datenmatrix.
Es ist auch erlaubt, ein Array des Typs 'Variant' zu übergeben. Dieses Array muss aber numerische Daten enthalten, also keine 'internen' Arrays, keine Strings und auch keine Objektverweise!

Die weiteren Parameter sind optional. Falls die Matrix zwar mit 'DIM' angelegt, aber noch nicht nit 'REDIM' dimensioniert worden ist, müssen die Parameter 'UG1', 'OG1', 'UG2', 'OG2' angegeben werden - die Parameter 'StartPos1' und 'StartPos2' werden ignoriert.

Durch UG1 bzw. OG1 können die Grenzen der ersten Dimension neu festgelegt werden. Durch UG2 bzw. OG2 können die Grenzen der zweiten Dimension neu festgelegt werden. Fehlt ein Parameter, wird die entsprechende Grenze der Matrix beibehalten. Die Obergrenze einer Dimension darf nicht kleiner als deren Untergrenze sein, sonst wird abgebrochen.
Durch 'StartPos1' kann die Start-Position der Daten auf der ersten Dimension vorgegeben werden; gefordert ist die Bedingung 'StartPos1 >= UG1'. Fehlt dieser Parameter, wird der neue Wert für 'UG1' verwendet (automatische Verschiebung; falls nicht gewünscht: 'Variante 2' verwenden - vgl. Quellcode). Durch 'StartPos2' kann die Startposition der Daten auf der zweiten Dimension vorgegeben werden (sonst wie 'StartPos1'). Der optionale boolsche Rückgabe-Parameter 'DatenVerlust' informiert darüber, ob durch die Redimensionierung Daten verloren gegangen sind ('false').

Arbeitsweise der Funktion 'REDIM_MATRIX':
Falls die Daten nicht vollständig ab der neuen Position eingefügt werden können, wird beim Kopieren entsprechend abgeschnitten und ein Teil der enthaltenen Daten geht verloren! Im nicht mit Daten belegten Bereich ist die redimensionierte Matrix ggf. - wie in VB üblich - mit '0' initialisiert. Bei der Übergabe ungeeigneter Parameter wird 'false' zurückgegeben und die Matrix wird nicht modifiziert.

Die Funktion 'Demo_RedimMatrix' demonstriert die Arbeitsweise von 'REDIM_MATRIX'. (Für den Rechenzeitbedarf dieser Routine ist überwiegend das elementweise Füllen und Prüfen der Matrix verantwortlich [ca. 90%], nicht die REDIM-Funktion!)

Details:
Die VB-Funktion 'IsMissing' liefert nur bei Variant-Parametern korrekte Angaben, weil in diesem Fall eine spezielle Kennung übergeben werden kann. Es handelt sich dabei eigentlich um eine 'Fehlerkennung' (IsError), bei der die Funktion 'CVERR' den Fehler 448 meldet ('benanntes Argument nicht gefunden'). Bei solchen Parametern muss in der Funktion eine Überprüfung des Inhalts erfolgen. Ein einfacher Test auf den gewünschten Datentyp durch die Funktion 'VarType' ist unzureichend, weil z.B. ein erwarteter LONG-Wert als INTEGER-Wert kommen kann, insbesondere dann, wenn im rufenden Programm ein Zahlenwert statt einer Variable übergeben worden ist. Die Funktion 'Check_LONG' zeigt, welche Überprüfungen im einzelnen notwendig sind. Sinnvoll ist die Anwendung einer expliziten Typumwandlungsfunktion vor der Bearbeitung des Inhalts eines Variant-Parameters.

Die Funktion 'REDIM' ohne das Schlüsselwort 'PRESERVE' gibt das bestehende Array zunächst frei. Deshalb ist in diesem Fall die Änderung der Zahl der Dimensionen eines dynamisch deklarierten Array möglich. Der Datentyp ist allerdings nicht änderbar, sondern muss konstant bleiben, wie in der DIM-Anweisung ursprünglich festgelegt. 'REDIM' birgt aber eine unangenehme Tücke: Wenn eine Array durch 'REDIM' dimensioniert wird, ohne zuvor durch eine DIM-Anweisung festgelegt zu werden, wird kein Fehler ausgelöst, sondern einfach ein neues Datenfeld angelegt (implizites DIM). Die 'OPTION EXPLICIT'-Anweisung wird dadurch unterlaufen. Tippfehler in einer REDIM-Anweisung können deshalb Probleme machen. Der Zugriff erfolgt nämlich weiterhin auf das bereits vorher bestehende Datenfeld, das nicht redimensioniert worden ist. Bei Verwendung der Funktion 'Redim_Matrix' kann dieses Problem nicht auftreten.

Details zur SafeArray-Struktur können im ExtraTipp 7/2005 Informationen zu Datenfeldern: die SafeArray-Struktur nachgelesen werden.

' ================================================================
' Start Quellcode Modul 'REDIM_MATRIX'
' ================================================================
Option Explicit
 
' Kopierfunktion für eine Bytefolge
Public 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 Redim_Matrix(ByRef Matrix As Variant, _
  Optional ByVal ug1 As Variant, _
  Optional ByVal og1 As Variant, _
  Optional ByVal ug2 As Variant, _
  Optional ByVal og2 As Variant, _
  Optional ByVal StartPos1 As Variant, _
  Optional ByVal StartPos2 As Variant, _
  Optional ByRef DatenVerlust As Boolean) As Boolean
 
  ' Redimensionierung einer numerischen Matrix über alle Grenzen
  ' unter (ggf. teilweiser) Beibehaltung des Inhalts,
  ' der dabei zugleich verschoben werden kann
 
  ' ug1, og1               neue Grenzen der ersten Dimension
  ' ug2, og2               neue Grenzen der zweiten Dimension
  ' StartPos1, StartPos2   'linke obere Ecke' des bisherigen
  '                        Matrixinhaltes
 
  Dim ai_matrix As udtArrayInfo      ' SafeArray-Struktur d. Matrix
  Dim el1 As Long, el2 As Long       ' Größe der Matrix
  Dim elt1 As Long, elt2 As Long     ' Größe (übertragene Teilmatrix)
  Dim TeilMatrix() As Byte           ' Matrixinhalt (Bytes) für Übertragung
  Dim Byte_Länge As Long             ' Länge eines Matrixelements
  Dim ndim As Boolean                ' nicht-dimensioniertes Array?
  Dim redimed As Boolean
 
  On Error GoTo fehler
 
  ' Rückgabe initialisieren
  DatenVerlust = False
 
  ' Eingabeparameter prüfen
  If Not IsArray(Matrix) Then Exit Function
 
  ' unterstützter Datentyp?
  Byte_Länge = GetTypeLeng(VarType(Matrix) - vbArray)
  If Byte_Länge < 1 Then Exit Function
 
  If Not ArrayInfo(Matrix, ai_matrix, ndim) Then
    ' SafeArray-Struktur fehlt ...
    If ndim Then
      ' SONDERFALL: Matrix ist noch nicht dimensioniert ...
      If IsMissing(ug1) Or IsMissing(ug2) Then Exit Function
      If IsMissing(og1) Or IsMissing(og2) Then Exit Function
      ' Variant-Parameter als Long darstellbar?
      If Not Check_LONG(ug1) Or Not Check_LONG(og1) Then Exit Function
      If Not Check_LONG(ug2) Or Not Check_LONG(og2) Then Exit Function
      ' sinnvolle Dimensionen?
      If ug1 > og1 Then Exit Function
      If ug2 > og2 Then Exit Function
      ' falls alle Grenzen korrekt gegeben worden sind:
      ' ---> REDIM direkt ausführen
      ReDim Matrix(ug1 To og1, ug2 To og2)
      Redim_Matrix = True      ' OK-Rückgabe
    End If
    Exit Function
  End If
 
  ' 2 Dimensionen sind gefordert
  If ai_matrix.Dimensionen <> 2 Then Exit Function
 
  ' 'Missing'-Parameter geeignet füllen (Default-Annahmen)
  If IsMissing(ug1) Then ug1 = LBound(Matrix, 1)
  If IsMissing(og1) Then og1 = UBound(Matrix, 1)
  If IsMissing(ug2) Then ug2 = LBound(Matrix, 2)
  If IsMissing(og2) Then og2 = UBound(Matrix, 2)
 
  ' Variante1
  ' (Daten am Anfang des redimensionierten Array einfügen)
  If IsMissing(StartPos1) Then StartPos1 = ug1
  If IsMissing(StartPos2) Then StartPos2 = ug2
 
  ' Variante2 (Daten ändern ihren urspr. Index nicht)
  ' If IsMissing(StartPos1) Then StartPos1 = lbound(matrix,1)
  ' If IsMissing(StartPos2) Then StartPos2 = lbound(matrix,2)
 
  ' Tja, die Variant-Parameter ....
  If Not Check_LONG(ug1) Or Not Check_LONG(og1) Then Exit Function
  If Not Check_LONG(ug2) Or Not Check_LONG(og2) Then Exit Function
  If Not Check_LONG(StartPos1) Or _
    Not Check_LONG(StartPos2) Then Exit Function
 
  ' Plausibilität der neu zusammengestellten
  ' Matrix-Dimensions-Grenzen?
  If ug1 > og1 Then Exit Function
  If ug2 > og2 Then Exit Function
 
  ' Die Startposition des Matrixinhalts muss innerhalb
  ' der neuen Matrix-Grenzen liegen
  ' Falls StartPos > og wird nichts übertragen!
  If StartPos1 < ug1 Or StartPos2 < ug2 Then Exit Function
 
  If ug1 = LBound(Matrix, 1) And og2 = UBound(Matrix, 1) _
    And ug2 = LBound(Matrix, 2) And og2 = UBound(Matrix, 2) _
    And StartPos1 = ug1 And StartPos2 = ug2 Then
    ' nichts zu tun ....
    Redim_Matrix = True: Exit Function
  End If
 
  ' Länge der bisherigen Dimensionen
  el1 = UBound(Matrix, 1) - LBound(Matrix, 1) + 1
  el2 = UBound(Matrix, 2) - LBound(Matrix, 2) + 1
 
  ' Größe der zu übertragenden Teilmatrix ermitteln
  ' angeforderte Verschiebung berücksichtigen
  elt1 = og1 - StartPos1 + 1
  elt2 = og2 - StartPos2 + 1
 
  If elt1 > 0 And elt2 > 0 Then
    ' bisheriger Matrix-Inhalt wird (teilweise) übernommen
    If elt1 > el1 Then elt1 = el1 ' mehr Elemente gibt es nicht
    If elt2 > el2 Then elt2 = el2 ' mehr Elemente gibt es nicht
 
    ' Teilmatrix mit den benötigten Bytes aus Matrix füllen
    If Not TeilMatrixB_Lesen(Matrix, TeilMatrix(), _
      LBound(Matrix, 1), LBound(Matrix, 2), _
      elt1, elt2) Then Exit Function
  End If
 
  ' Tritt ein Verlust von Daten auf?
  DatenVerlust = elt1 < el1 Or elt2 < el2
  redimed = True
  ' Matrix mit den modifizierten Grenzen neu deklarieren
  ReDim Matrix(ug1 To og1, ug2 To og2)
 
  ' Teilmatrix ggf. wieder eintragen
  If elt1 > 0 And elt2 > 0 Then
    If Not TeilMatrixB_Schreiben(Matrix, TeilMatrix(), _
      StartPos1, StartPos2) Then GoTo fehler
  End If
  Redim_Matrix = True
  Exit Function
 
fehler:
  ' Falls Fehler nach dem Redimensionieren auftritt: Datenverlust
  ' z.B. Speichermangel
  DatenVerlust = redimed
End Function

Private Function Check_LONG(ByRef value As Variant) As Boolean
  ' Hilfsfunktion:
  ' Falls 'value' nicht als Ganzzahl (LONG) korrekt
  ' darstellbar ist, wird 'False' zurückgegeben
 
  On Error GoTo fehler
 
  Const epsilon As Double = 0.00000000001
  Const MaxLong As Long = 2147483647
 
  If Not IsNumeric(value) Then Exit Function
  If Abs(value - Fix(value)) > epsilon Then Exit Function
  If Abs(value) > MaxLong Then Exit Function
 
  value = CLng(value)
  Check_LONG = True
 
fehler:
End Function
 
Private Function GetTypeLeng(ByVal typ As VbVarType) As Long
  ' Länge eines unterstützten Datentyps in Byte
  Dim b As Long
 
  b = -1
  If typ = vbByte Then b = 1
  If typ = vbInteger Or typ = vbBoolean Then b = 2
  If typ = vbLong Or typ = vbSingle Then b = 4
  If typ = vbDouble Or typ = vbDate Or typ = vbCurrency Then b = 8
  If typ = vbDecimal Or typ = vbVariant Then b = 16 ' Variant
 
  GetTypeLeng = b
End Function

Public Function TeilMatrixB_Lesen(ByRef Matrix As Variant, _
  ByRef TeilMatrix() As Byte, _
  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
 
  ' Die erste Dimension der TeilMatrix ist abhängig vom
  ' Datentyp der Matrix (Bytes/Feld)
 
  Dim quell_ptr As Long, ziel_ptr As Long          ' Matrix-Zeiger
  Dim pos As Long, i As Long, z As Long            ' Loop
  Dim ai_m As udtArrayInfo, ai_tm As udtArrayInfo  ' SafeArray-Struktur
  Dim lb1 As Long, lb2 As Long                     ' Grenzen
  Dim ub1 As Long, ub2 As Long
  Dim Byte_Länge As Long                           ' für 1 Array-Element
 
  On Error GoTo fehler
 
  ' Eingabeparameter prüfen
  If Not IsArray(Matrix) 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
  Byte_Länge = GetTypeLeng(VarType(Matrix) - vbArray)
  If Byte_Länge < 1 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 für Bytes einrichten
  ReDim TeilMatrix(1 To Byte_Länge, 1 To ZuLesen1, 1 To ZuLesen2)
 
  ' nach REDIM ArrayInfo neu lesen (wg. Data_Pointer !!)
  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_m.Bytes_Pro_Feld)
 
    ' Zeiger jeweils um eine Dimension hochsetzen
    quell_ptr = quell_ptr + (ub1 - lb1 + 1) * ai_m.Bytes_Pro_Feld
    ziel_ptr = ziel_ptr + ZuLesen1 * ai_m.Bytes_Pro_Feld
  Next i
  TeilMatrixB_Lesen = True
 
fehler:
End Function

Private Function TeilMatrixB_Schreiben(ByRef Matrix As Variant, _
  ByRef TeilMatrix() As Byte, _
  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)
 
  ' Die erste Dimension der TeilMatrix muss korrespondieren
  ' mit der Byte-Länge des Datentyps der Matrix (Bytes/Feld)
 
  Dim quell_ptr As Long, ziel_ptr As Long         ' Array-Zeiger
  Dim pos As Long, i As Long, z As Long           ' Loop
  Dim ai_m As udtArrayInfo, ai_tm As udtArrayInfo ' SafeArray-Struktur
  Dim lb1 As Long, lb2 As Long                    ' Matrix-Grenzen
  Dim ub1 As Long, ub2 As Long
  Dim ZuSchreiben1 As Long, ZuSchreiben2 As Long
  Dim Byte_Länge As Long
 
  On Error GoTo fehler
 
  ' Eingabeparameter prüfen
  If Not IsArray(Matrix) Then Exit Function
 
  Byte_Länge = GetTypeLeng(VarType(Matrix) - vbArray)
  If Byte_Länge < 1 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 <> 3 Then Exit Function
  If UBound(TeilMatrix, 1) <> Byte_Länge Then Exit Function
  If LBound(TeilMatrix, 1) <> 1 Then Exit Function
 
  ZuSchreiben1 = UBound(TeilMatrix, 2) - LBound(TeilMatrix, 2) + 1
  ZuSchreiben2 = UBound(TeilMatrix, 3) - LBound(TeilMatrix, 3) + 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_m.Bytes_Pro_Feld)
 
    ' Zeiger jeweils um eine Dimension hochsetzen
    quell_ptr = quell_ptr + (ub1 - lb1 + 1) * ai_m.Bytes_Pro_Feld
    ziel_ptr = ziel_ptr + ZuSchreiben1 * ai_m.Bytes_Pro_Feld
  Next i
  TeilMatrixB_Schreiben = True
 
fehler:
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
 
  ' Hilfsfunktion für: TeilMatrixB_Lesen / _Schreiben
 
  ' absolute Position eines Datenfeldes in einem
  ' zwei-dimensionalen VB-Array
  ' lb1, ub1, lb2, ub2  - Dimensionen des Array
  ' pos1, pos2 - Indices des Array-Elements
  ' unplausible Eingaben: Rückgabe -1
 
  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, _
  Optional ByRef Nicht_Dimensioniert As Boolean) As Boolean
 
  ' Arrayinfos abfragen (SafeArray-Struktur)
 
  Dim vtp As Long, ptr As Long
 
  Nicht_Dimensioniert = False
  If Not IsArray(Matrix) Then Exit Function
 
  ' (Array muss über einen Variant-Parameter
  ' ByRef' übergeben worden sein, damit das klappt)
  Call CopyMemory(vtp, ByVal VarPtr(Matrix) + 8, 4)
  If vtp = 0 Then Exit Function
  Call CopyMemory(ptr, ByVal vtp, 4&)
  If ptr = 0 Then
    ' SafeArray ist bei nicht-dimensionierten Arrays
    ' nicht vorhanden
    Nicht_Dimensioniert = True
    Exit Function
  End If
 
  ' vorderen Teil der SafeArray-Struktur lesen
  Call CopyMemory(ai, ByVal ptr, 16&)
  ArrayInfo = True
End Function

Demo: ReDimMatrix

Public Function Demo_RedimMatrix() As Boolean
  ' DEMONSTRATION der Anwendung von 'REDIM_MATRIX'
 
  ' Die Routine dimensioniert in einer Schleife
  ' eine Matrix und füllt sie mit Zufallswerten
 
  ' Die Matrix wird jeweils redimensioniert
  ' und ihr Inhalt dabei zufällig verschoben
  ' Das Ergebnis dieser Operation wird überprüft
 
  Dim ug1&, og1&, ug2&, og2&        ' Matrix-Dim
  Dim nug1&, nog1&, nug2&, nog2&    ' Matrix-ReDim
  Dim el1&, el2&                    ' Umfang der Dimensionen
  Dim StartPos1&, StartPos2&        ' neue Position Matrix-Inhalt
 
  Dim i&, k&, im&, km&, du&         ' Loops
 
  Dim Matrix() As Variant           ' Als Beispiel dient eine Variant-Matrix
  Dim Matrix_Alt() As Variant       ' Backup für den Inhaltsvergleich
 
  Dim zeit#, bedarf#                ' Ermittlung Zeitbedarf REDIM
  Const cTestLäufe As Long = 50     ' Testparameter
  Const cMatrixGröße As Long = 1000
 
  ' Testdurchgänge
  For du = 1 To cTestLäufe
    ' zufällige Dimensionen der Matrix
    og1 = Rnd * cMatrixGröße + 1
    og2 = Rnd * cMatrixGröße + 1
    ug1 = Rnd * (og1 - 1) + 1
    If Rnd > 0.5 Then ug1 = -ug1
    ug2 = Rnd * (og2 - 1) + 1
    If Rnd > 0.5 Then ug2 = -ug2
 
    ' Matrix erstellen
    If Not Redim_Matrix(Matrix(), ug1, og1, ug2, og2) Then
      MsgBox "Matrix kann nicht erstellt werden"
      Exit Function
    End If
 
    ' Matrix komplett füllen (dauert jeweils einen Moment)
    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
 
    ' BackUp für Test anlegen
    Matrix_Alt() = Matrix()
 
    ' zufällige neue Dimensionen für die Matrix
    nog1 = Rnd * cMatrixGröße + 1
    nog2 = Rnd * cMatrixGröße + 1
    nug1 = Rnd * (nog1 - 1) + 1
    If Rnd > 0.5 Then nug1 = -nug1
    nug2 = Rnd * (nog2 - 1) + 1
    If Rnd > 0.5 Then nug2 = -nug2
 
    ' zufällige Positionierung des ArrayInhaltes
    ' in der neuen Matrix
    StartPos1 = Rnd * (nog1 - nug1) + nug1
    StartPos2 = Rnd * (nog2 - nug2) + nug2
 
    ' Matrix neu dimensionieren
    zeit = Timer
    If Not Redim_Matrix(Matrix(), nug1, nog1, nug2, nog2, StartPos1, StartPos2) Then
      MsgBox "Redimensionierung scheitert"
      Exit Function
    End If
 
    ' Summation Zeitbedarf REDIM_MATRIX
    zeit = Timer - zeit
    If zeit > 0 Then
      bedarf = bedarf + zeit
    End If
 
    ' Dimensionierung der Matrix prüfen
    If LBound(Matrix, 1) <> nug1 Or UBound(Matrix, 1) <> nog1 _
      Or LBound(Matrix, 2) <> nug2 Or UBound(Matrix, 2) <> nog2 Then
      MsgBox "Redimensionierung fehlerhaft"
      Exit Function
    End If
 
    ' Positionierung des übernommenen (Teil-)Inhalts prüfen
    el1 = og1 - ug1 + 1
    el2 = og2 - ug2 + 1
 
    For i = 1 To el1
      im = StartPos1 + i - 1
      If im <= nog1 Then
        For k = 1 To el2
          km = StartPos2 + k - 1
          If km <= nog2 Then
            ' Ist der Inhalt ab der gewünschten Stelle eingefügt
            ' (so weit er in die neu dimensionierte Matrix passt) ?
            If Matrix(im, km) <> Matrix_Alt(ug1 + i - 1, ug2 + k - 1) Then
              MsgBox "Inhalt fehlerhaft übertragen"
              Exit Function
            End If
          End If
        Next k
      End If
    Next i
 
    ' nächster Test-Durchgang
  Next du
 
  Demo_RedimMatrix = True
  MsgBox "Demo zu 'REDIM Matrix' erfolgreich ausgeführt" + vbCrLf + _
    "Zeitbedarf REDIM_MATRIX: " + CStr(Round(bedarf, 5)) + " Sekunden"
End Function
 
' ================================================================
' Ende Quellcode Modul 'REDIM_MATRIX'
' ================================================================