'Attribute VB_Name = "arrDimension"
Option Explicit
' ---------------------------------------------------------
' Funktion: arrDimension
' Eingestellt von: Andre Schau
' Datum: 5. Juno 2006
' Kommentar: Ausgabe der Anzahl der Array-Dimensionen
' Parameter:
' Rückgabe: Anzahl der Array-Dimensionen
' Hinweis: Verwendung ungeprüfter Datentypen (As Any)
' ---------------------------------------------------------
Private Declare Sub RtlMoveMemory Lib "kernel32" _
(dest As Any, source As Any, ByVal bytes As Long)
Sub call_arrDimension()
'Variablendeklarationen
'Integer
Dim iInt%
'String
Dim strMyMsg$
'Arrays
'Variant
Dim arrStr() '1-dimensionales Variant-Array
'Integer
Dim arrInt(1) As Integer '1-dimensionales Integer-Array
'Long
Dim arrLng(1, 2) As Long '2-dimensionales Long-Array
'Date
Dim arrDat(1, 2, 3) As Date '3-dimensionales Date-Array
'-------------------------------------------------------
'Meldungsstring mit Ergebnissen der Arraypruefung bilden
'Pruefen der Auswirkung von Dim, Array, Redim und Erase
strMyMsg = "arrStr leer: " & _
arrDimension(arrStr) & vbLf '0
'Array arrStr mit Wert 1 fuellen
arrStr = Array(1)
strMyMsg = strMyMsg & "arrStr gefuellt: " & _
arrDimension(arrStr) & vbLf '1
'Array arrStr mit Erase zuruecksetzen
Erase arrStr
strMyMsg = strMyMsg & "arrStr geloescht: " & _
arrDimension(arrStr) & vbLf '0
'Array arrStr mit Wert 1 fuellen und mit Redim leeren
arrStr = Array(1): Redim arrStr(0)
strMyMsg = strMyMsg & "arrStr Redimens.: " & _
arrDimension(arrStr) & vbLf '1
strMyMsg = strMyMsg & "------------------" & vbLf
'Pruefen verschiedener Dimensionen
strMyMsg = strMyMsg & "1-D-Array arrInt: " & _
arrDimension(arrInt) & vbLf '1
strMyMsg = strMyMsg & "2-D-Array arrLng: " & _
arrDimension(arrLng) & vbLf '2
strMyMsg = strMyMsg & "3-D-Array arrDat: " & _
arrDimension(arrDat) & vbLf '3
strMyMsg = strMyMsg & "------------------" & vbLf
strMyMsg = strMyMsg & "Integer-Variable: " & _
arrDimension(iInt) '-1
'Meldung ausgeben
MsgBox strMyMsg
End Sub
Function arrDimension(ByRef varVarName As Variant) As Integer
'Funktion zur Ermittlung der Anzahl von Dimensionen
'eines Arrays
'Verwendet die API RtlMoveMemory
'Variablendeklaration
'Long
Dim Ptr As Long
'Wenn Variable ein Array ist, dann
If IsArray(varVarName) Then
'Adresse des Arrays im Speicher feststellen
'verwendet undokumentierte Funktion VarPtr
Ptr = VarPtr(varVarName) + 8
'Zeiger auf SafeArrayDescriptor
RtlMoveMemory Ptr, ByVal Ptr, 4
'Zeiger auf SafeArray-Struktur
RtlMoveMemory Ptr, ByVal Ptr, 4
'Wenn Ptr dann Anzahl Dimensionen ermitteln
'Hinweis: Ptr ist 0, wenn Datenfeld leer ist
'( nach Dim arr() oder Erase arr )
If Ptr Then RtlMoveMemory arrDimension, ByVal Ptr, 2
'Wenn nicht, dann
Else
'Rueckgabewert -1
arrDimension = -1
End If
End Function