【VBA】SafeArrayGetDim を使って、配列の次元数を求める

SafeArrayGetDim.bas

Option Explicit

'引数は、SAFEARRAY を指すポインタを値渡し
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32" (ByVal psa As LongPtr) As Long

'Source:
'   ByRef ：Sourceに格納されている「値」をDestinationにコピーする
'   ByVal ：Sourceに格納されている「アドレスにある値」をDestinationにコピーする
'   ByVal VarPtr(v) + Offset ：変数v から Offset 移動したアドレスにある値をDestinationにコピーする
'Remarks
'   SourceとLengthで定義されるソース・メモリ・ブロックは、
'   DestinationとLengthで定義されるデスティネーション・メモリ・ブロックと
'   オーバーラップすることができます。
'Link
'   https://learn.microsoft.com/en-us/windows/win32/devnotes/rtlmovememory
Private Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)


Private Function getSafeArrayPointer(ByRef v As Variant) As LongPtr

    Const VT_ARRAY          As Integer = &H2000
    Const VT_BYREF          As Integer = &H4000
    Const OFFSET_PARRAY     As Long = 8&

    Dim pArray  As LongPtr
    Dim vt      As Integer

    'VARIANT構造体の先頭にある vt (VARTYPE)を引っ張ってくる
    Call RtlMoveMemory(vt, v, Len(vt))

    If (vt And VT_ARRAY) = 0 Then
        '配列ではない
        Debug.Print "v is not array."
        Exit Function
    End If

    'VARIANT構造体のparray(SAFEARRAY*)のアドレスの「値」を引っ張ってくる
    Call RtlMoveMemory(pArray, ByVal VarPtr(v) + OFFSET_PARRAY, Len(pArray))

    If (vt And VT_BYREF) = VT_BYREF Then
        'VARIANT構造体のpparray(SAFEARRAY**)から、parrayの「アドレス」を引っ張ってくる
        Call RtlMoveMemory(pArray, ByVal pArray, Len(pArray))
    End If

    If pArray = 0 Then
        '動的配列でRedimがまだか、Eraseした後
        Exit Function
    End If

    getSafeArrayPointer = pArray

End Function

Public Sub getDimVariantArray()

    Dim v   As Variant
    Dim psa As LongPtr

    v = Array(1, 2, 3)
    psa = getSafeArrayPointer(v)

    Debug.Print SafeArrayGetDim(psa)

End Sub

Public Sub getDimVariantRefArray()

    Dim lArray() As Long
    Dim v   As Variant
    Dim psa As LongPtr

    ReDim lArray(3, 5, 7)
    v = lArray
    psa = getSafeArrayPointer(v)

    Debug.Print SafeArrayGetDim(psa)

End Sub

Public Sub getDimFixArray()

    Dim psa As LongPtr
    Dim lArray(3, 4, 5, 6, 7) As Long

    psa = getSafeArrayPointer(lArray)

    Debug.Print SafeArrayGetDim(psa)

End Sub