Option Explicit
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Enum VariantTypes
VTx_Empty = vbEmpty
VTx_Array = vbArray
VTx_ByRef = &H4000
End Enum
Type VariantStruct
A_VariantType As Integer
B_Reserved(1 To 6) As Byte
C_Data As LongLong
End Type
Type ArrayStruct
A_DimCount As Integer
B_FeatureFlags As Integer
C_ElementSize As Long
D_LockCount As Long
E_DataPtr As Long
F_BoundsInfoArr As LongLong
End Type
Function ArrayDims(SomeArray As Variant) As Long
Dim DataPtrOffset As Integer
Dim DimCount As Integer
Dim VariantType As Integer
Dim VariantDataPtr As LongLong
Call CopyMemory(VariantType, SomeArray, LenB(VariantType))
If (VariantType And VTx_Array) Then
Dim VariantX As VariantStruct
DataPtrOffset = LenB(VariantX) - LenB(VariantX.C_Data)
Call CopyMemory(VariantDataPtr, ByVal VarPtr(SomeArray) + DataPtrOffset, LenB(VariantDataPtr))
If VariantDataPtr <> 0 Then
If (VariantType And VTx_ByRef) Then
Call CopyMemory(VariantDataPtr, ByVal VariantDataPtr, LenB(VariantDataPtr))
End If
If VariantDataPtr <> 0 Then
Call CopyMemory(DimCount, ByVal VariantDataPtr, LenB(DimCount))
End If
End If
End If
ArrayDims = DimCount
End Function
Sub Demo_ArrayDims()
Dim Test2DArray As Variant
Dim Test3DArray() As Long
Debug.Print
Debug.Print ArrayDims(Array(20, 30, 400))
Test2DArray = [{0, 0, 0, 0; "Apple", "Fig", "Orange", "Pear"}]
Debug.Print ArrayDims(Test2DArray)
ReDim Test3DArray(1 To 3, 0 To 1, 1 To 4)
Debug.Print ArrayDims(Test3DArray)
End Sub