Pointers to arrays stored as collection/dictionary items VBA

问题

With variant arrays where each element is a double array I am able to do the following:

Public Declare PtrSafe Sub CopyMemoryArray Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination() As Any, ByRef Source As Any, ByVal Length As Long)

Sub test()
    Dim vntArr() as Variant
    Dim A() as Double
    Dim B() as Double

    Redim vntArr(1 to 10)
    Redim A(1 to 100, 1 to 200)
    vntArr(1) = A
    CopyMemoryArray B, ByVal VarPtr(vntArr(1)) + 8, PTR_LENGTH '4 or 8
    'Do something
    ZeroMemoryArray B, PTR_LENGTH
End Sub

A and B will then point to the same block in memory. (Setting W = vntArr(1) creates a copy. With very large arrays, I want to avoid this.)

I'm trying to do the same, but with collections:

Sub test()
    Dim col as Collection
    Dim A() as Double
    Dim B() as Double

    Set col = New Collection
    col.Add A, "A"
    CopyMemoryArray B, ByVal VarPtr(col("A")) + 8, PTR_LENGTH '4 or 8
    'Do something
    ZeroMemoryArray B, PTR_LENGTH
End Sub

This sort of works, but for some reason the safe array structure (wrapped in Variant data type, similar to the variant array above) returned by col("A") only contains some exterior attributes like number of dimensions and dim boundaries, but the pointer to the pvData itself is empty, and so CopyMemoryArray call results in a crash. (Setting B = col("A") works fine.) Same situation with Scripting.Dictionary.

Does anyone know what's going on here?

EDIT

#If Win64 Then
    Public Const PTR_LENGTH As Long = 8
#Else
    Public Const PTR_LENGTH As Long = 4
#End If

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const VT_BYREF As Long = &H4000&
Private Const S_OK As Long = &H0&

Private Function pArrPtr(ByRef arr As Variant) As LongPtr
    Dim vt As Integer

    CopyMemory vt, arr, 2
    If (vt And vbArray) <> vbArray Then
        Err.Raise 5, , "Variant must contain an array"
    End If
    If (vt And VT_BYREF) = VT_BYREF Then
        CopyMemory pArrPtr, ByVal VarPtr(arr) + 8, PTR_LENGTH
        CopyMemory pArrPtr, ByVal pArrPtr, PTR_LENGTH
    Else
        CopyMemory pArrPtr, ByVal VarPtr(arr) + 8, PTR_LENGTH
    End If
End Function

Private Function GetPointerToData(ByRef arr As Variant) As LongPtr
    Dim pvDataOffset As Long
    #If Win64 Then
        pvDataOffset = 16 '4 extra unused bytes on 64bit machines
    #Else
        pvDataOffset = 12
    #End If
    CopyMemory GetPointerToData, ByVal pArrPtr(arr) + pvDataOffset, PTR_LENGTH
End Function

Sub CollectionWorks()
    Dim A(1 To 100, 1 To 50) As Double

    A(3, 1) = 42

    Dim c As Collection
    Set c = New Collection

    c.Add A, "A"

    Dim ActualPointer As LongPtr
    ActualPointer = GetPointerToData(c("A"))

    Dim r As Double
    CopyMemory r, ByVal ActualPointer + (0 + 2) * 8, 8

    MsgBox r  'Displays 42
End Sub

回答1:

VB is designed to hide complexity. Often that results in very simple and intuitive code, sometimes it does not.

A VARIANT can contain an array of non-VARIANT data no problem, such as an array of proper Doubles. But when you try to access this array from VB, you don't get a raw Double like it is actually stored is the blob, you get it wrapped in a temporary Variant, constructed at the time of access, specifically to not surprise you with the fact that an array declared As Variant suddenly produces a value As Double. You can see that in this example:

Sub NoRawDoubles()
  Dim A(1 To 100, 1 To 50) As Double
  Dim A_wrapper As Variant

  A_wrapper = A

  Debug.Print VarPtr(A(1, 1)), VarPtr(A_wrapper(1, 1))
  Debug.Print VarPtr(A(3, 3)), VarPtr(A_wrapper(3, 3))
  Debug.Print VarPtr(A(5, 5)), VarPtr(A_wrapper(5, 5))
End Sub

On my computer the result is:

88202488      1635820 
88204104      1635820 
88205720      1635820

Elements from A are in fact different and are located in memory where they should within the array and each one is 8 bytes in size, whereas "elements" of A_wrapper are in fact the same "element" - that number repeated three times is the address of the temporary Variant, 16 bytes in size, that is created to hold the array element and which the compiler decided to reuse.

That is why an array element returned in this way cannot be used for pointer arithmetic.

Collections themselves do not add anything to this problem. It's the fact that Collection has to wrap the data it stores in a Variant that messes it up. It would happen when storing an array in a Variant in any other place too.

To get the actual unwrapped data pointer suitable for pointer arithmetic, you need to query the SAFEARRAY* pointer from the Variant, where it can be stored with one or two levels of indirection, and take the data pointer from there.

Building on previous examples, the naive non-x64-compatible code for that would be:

Private Declare Function GetMem2 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long  ' Replace with CopyMemory if feel bad about it
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long  ' Replace with CopyMemory if feel bad about it

Private Const VT_BYREF As Long = &H4000&

Private Function pArrPtr(ByRef arr As Variant) As Long  'Warning: returns *SAFEARRAY, not **SAFEARRAY
  'VarType lies to you, hiding important differences. Manual VarType here.
  Dim vt As Integer
  GetMem2 ByVal VarPtr(arr), ByVal VarPtr(vt)

  If (vt And vbArray) <> vbArray Then
    Err.Raise 5, , "Variant must contain an array"
  End If


  'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx
  If (vt And VT_BYREF) = VT_BYREF Then
    'By-ref variant array. Contains **pparray at offset 8
    GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr)  'pArrPtr = arr->pparray;
    GetMem4 ByVal pArrPtr, ByVal VarPtr(pArrPtr)          'pArrPtr = *pArrPtr;
  Else
    'Non-by-ref variant array. Contains *parray at offset 8
    GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr)  'pArrPtr = arr->parray;
  End If

End Function

Private Function GetPointerToData(ByRef arr As Variant) As Long
  GetMem4 pArrPtr(arr) + 12, VarPtr(GetPointerToData)
End Function

Which then can be used in the following non-x64-compatible way:

Sub CollectionWorks()
  Dim A(1 To 100, 1 To 50) As Double

  A(3, 1) = 42

  Dim c As Collection
  Set c = New Collection

  c.Add A, "A"

  Dim ActualPointer As Long
  ActualPointer = GetPointerToData(c("A"))

  Dim r As Double
  GetMem4 ActualPointer + (0 + 2) * 8, VarPtr(r)
  GetMem4 ActualPointer + (0 + 2) * 8 + 4, VarPtr(r) + 4

  MsgBox r  'Displays 42
End Sub

Note that I am not sure that c("A") returns the same actual data every time as opposed to making copies as it pleases, so caching the pointer in this way may not be advised, and you might be better off first saving the result of c("A") into a variable and then calling GetPointerToData off that.

Obviously this should be rewritten to use LongPtr and CopyMemory, and I might do that tomorrow, but you get the idea.

回答2:

It's easier if you treat both the base variables as Variant.

Option Explicit

#If Vba7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#End If


Sub test()
    Dim col As Variant
    Dim B As Variant
    Dim A() As Double

    ReDim A(1 To 100, 1 To 200)
    A(1, 1) = 42
    Set col = New Collection
    col.Add A, "A"
    Debug.Print col("A")(1, 1)

    CopyMemory B, col, 16
    Debug.Print B("A")(1, 1)

    FillMemory B, 16, 0
End Sub

Also see these helpful links

Partial Arrays by reference

Copy an array reference in VBA

How do I slice an array in Excel VBA?

http://bytecomb.com/vba-reference/

来源：https://stackoverflow.com/questions/43552182/pointers-to-arrays-stored-as-collection-dictionary-items-vba

标签

excel