VBA获取数组的维度

'获取数组的维度
Function GetArrayDimsByErr(v As Variant) As Long
    If Not VBA.IsArray(v) Then
        GetArrayDimsByErr = 0
        Exit Function
    End If
    
    On Error Resume Next
    Dim tmp As Long
    GetArrayDimsByErr = -1
    Do Until Err.Number <> 0
        GetArrayDimsByErr = GetArrayDimsByErr + 1
        tmp = UBound(v, GetArrayDimsByErr + 1)
    Loop
    On Error GoTo 0
End Function

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Type SafeArrayBound
    cElements As Long '// 该维的长度
    lLbound   As Long '  该维的数组存取的下限，一般为0
End Type


Private Type SafeArray
    cDims      As Integer ' // 数组的维度
    fFeatures  As Integer '
    cbElements As Long ' // 数组元素的字节大小
    cLocksas   As Long '
    pvDataas   As Long ' // 数组的数据指针
    rgsabound() As SafeArrayBound
End Type


'获取数组的维度
Function GetArrayDims(v As Variant) As Long
    If Not VBA.IsArray(v) Then
        GetArrayDims = 0
        Exit Function
    End If
    
    Dim ptr As Long
    Dim sa As SafeArray
    
    ptr = MyArrayPtr(v)
    
    CopyMemory VarPtr(sa.cDims), ptr, 4
    
    GetArrayDims = sa.cDims
End Function


Function MyArrayPtr(ByRef v As Variant) As Long
    Dim b(16 - 1) As Byte
    
    CopyMemory VarPtr(b(0)), VarPtr(v), 16
    
    Dim ptr As Long
    CopyMemory VarPtr(ptr), VarPtr(b(8)), 4
'    - 0x20 8-11存的是数组地址
'    - 0x60 8-11存的是数组地址的地址
    If b(1) = &H60 Then
        CopyMemory VarPtr(ptr), ptr, 4
    End If
    
    MyArrayPtr = ptr
End Function