'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