VB/VBA保险数组（SafeArray）研究

Private Type VariantAPI
'Variant():  vt=8204(vbVariant or vbArray)
'数组为单元格区域直接赋值时,类型为Variant()
    vt As Integer                                     '类型，2字节
    wReserved1 As Integer
    wReserved2 As Integer
    wReserved3 As Integer
    dwReserved1 As Long                               '数据
    dwReserved2 As Long
End Type


Private Type SFArrayBOUND
    cElements As Long                                 '这一维元素数量
    lLbound As Long                                   '索引开始值，即LBOUND值
End Type

Private Type SAFEARRAY
    cDims As Integer                                   '数组维数
    fFeature As Integer                                '数组特性
    cbElements As Long                                 '数组元素字节数
    cLocks As Long                                     '锁定次数
    pvData As Long                                     '数组数据指针
    rgsabound() As SFArrayBOUND
End Type
Const VT_BYREF = &H4000

Private Declare Function ppVariantArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr As Any) As Long

Private Declare Function ppArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByVal pSA As Long) As Long
Private Declare Function SafeArrayLock Lib "oleaut32.dll" (ByVal pSA As Long) As Long
Private Declare Function SafeArrayUnlock Lib "oleaut32.dll" (ByVal pSA As Long) As Long

Private Declare Function SafeArrayAccessData Lib "oleaut32.dll" (ByVal pSA As Long, ppVdata As Long) As Long
Private Declare Function SafeArrayUnaccessData Lib "oleaut32.dll" (ByVal pSA As Long) As Long
Private Declare Function SafeArrayGetElemsize Lib "oleaut32.dll" (ByVal pSA As Long) As Long


Private Sub MAIN()
    Dim v As VariantAPI, v1 As VariantAPI
    Dim sfArray As SAFEARRAY, sfArray1 As SAFEARRAY, sfArray2 As SAFEARRAY, sfArray3 As SAFEARRAY
    Dim pSA As Long
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim arr0, arrr0(5) As Long
    ReDim arr0(5) As Long '元素为long类型
    For i = 0 To UBound(arr0)
        arr0(i) = i
    Next

    '元素为long
    pSA = GetSafeArrayPointer(arr0)
    sfArray = GetSafeArray(pSA)

    'copy数组
    CopyArray VarPtr(arrr0(0)), sfArray.pvData, 4, 6

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'单元格数据数组
    Dim arr1, arrr1(3) As Variant
    arr1 = [a1:b2]   '元素为variant类型
    pSA = GetSafeArrayPointer(arr1)
    sfArray = GetSafeArray(pSA)
    'copy数组
    CopyArray VarPtr(arrr1(0)), sfArray.pvData, 16, 4
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim ppVdata As Long
    r = SafeArrayAccessData(ByVal pSA, ppVdata) '这里ppvdata==sfArray.pvData
    r = SafeArrayUnaccessData(ByVal pSA)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'数组的访问方式
    Dim arr3() As Long, arrr3(12) As Long
    ReDim arr3(12)
    For i = 0 To UBound(arr3)
        arr3(i) = i
    Next

    '方式一：
    pSA = GetSafeArrayPointer(arr3)
    sfArray1 = GetSafeArray(pSA)
    
    '方式二：效果同方式一
    Dim pArray As Long
    pArray = GetPointerFromPP(ppArray(arr3))
    sfArray2 = GetSafeArray(pArray)

    '方式三：建议用方式一，ppvdata为数组数据指针
    r = SafeArrayAccessData(pArray, ppVdata)
    r = SafeArrayUnaccessData(pArray)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '复制字符串数组
    Dim arr4() As String, arrr4(12) As String
    ReDim arr4(12)
    For i = 0 To UBound(arr4)
        arr4(i) = "s" & i
    Next
    
    pSA = GetSafeArrayPointer(arr4)
    sfArray = GetSafeArray(pSA)
    
    CopyArray VarPtr(arr4(0)), sfArray.pvData, 4, 13

End Sub


Private Sub CopyArray(pDestinationArrayElement As Long, pSourceArrayElement As Long, cbElement As Long, iCount As Long)
    CopyMemory ByVal pDestinationArrayElement, ByVal pSourceArrayElement, iCount * cbElement
End Sub

Private Function GetArrayDim(pArray As Long) As Long
    GetArrayDim = SafeArrayGetDim(pArray)
End Function

'解引用
Private Function GetPointerFromPP(pPointer As Long) As Long
    CopyMemory GetPointerFromPP, ByVal pPointer, 4
End Function

Private Function GetVariant(arr) As VariantAPI
    CopyMemory GetVariant, (arr), LenB(GetVariant)
    PrintVar GetVariant
End Function


Private Function GetSafeArrayPointer(arr) As Long
    Dim v As VariantAPI
    CopyMemory v, ByVal VarPtr(arr), LenB(v)
    If CBool(v.vt And VT_BYREF) Then
        CopyMemory GetSafeArrayPointer, ByVal v.dwReserved1, 4
    Else
        GetSafeArrayPointer = v.dwReserved1
    End If
End Function

Private Function GetSafeArray(pSafeArray As Long) As SAFEARRAY
    Dim v As VariantAPI, pSA As Long
    CopyMemory GetSafeArray, ByVal pSafeArray, ByVal (LenB(GetSafeArray) - 4)
    ReDim GetSafeArray.rgsabound(GetSafeArray.cDims - 1)
    CopyMemory GetSafeArray.rgsabound(0), ByVal pSafeArray + 16, GetSafeArray.cDims * 8
'    PrintSAFEARRAY GetSafeArray
End Function