指向存储为集合/字典项 VBA 的数组的指针

Question

对于每个元素都是双精度数组的变体数组，我可以执行以下操作：

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 和 B 将指向内存中的同一个块。 （设置 W = vntArr(1) 会创建一个副本。对于非常大的数组，我想避免这种情况。）

我正在尝试做同样的事情，但使用集合：

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

这种方法可行，但由于某种原因，由 col("A") 返回的安全数组结构（包装在 Variant 数据类型中，类似于上面的变体数组）仅包含一些外部属性，例如维度数和模糊边界，但指向pvData 的指针本身为空，因此调用 CopyMemoryArray 会导致崩溃。 （设置 B = col("A") 工作正常。）与 Scripting.Dictionary 的情况相同。

有人知道这里发生了什么吗？

---

编辑

#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

Answer 1

VB 旨在隐藏复杂性。这通常会产生非常简单直观的代码，但有时不会。

一个VARIANT可以包含一个非VARIANT数据的数组没问题，比如一个正确的Doubles数组。但是当你尝试从 VB 访问这个数组时，你不会得到一个原始的Double，就像它实际上存储的是 blob，你把它包装在一个临时的 Variant 中，在访问时构建，特别是声明为As Variant 的数组突然产生了一个值As Double，这并不会让您感到惊讶。你可以在这个例子中看到：

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

在我的电脑上结果是：

88202488      1635820 
88204104      1635820 
88205720      1635820

A 中的元素实际上是不同的，它们位于内存中它们应该在数组中的位置，每个元素的大小为 8 个字节，而 A_wrapper 的“元素”实际上是相同的“元素”——即重复 3 次的数字是临时 Variant 的地址，大小为 16 字节，创建它是为了保存数组元素，编译器决定重用它。

---

这就是为什么以这种方式返回的数组元素不能用于指针运算。

集合本身不会给这个问题增加任何东西。事实上，Collection 必须将它存储的数据包装在 Variant 中，这会搞砸它。将数组存储在任何其他地方的 Variant 中也会发生这种情况。

---

要获得适合指针运算的实际解包数据指针，您需要从Variant 中查询SAFEARRAY* 指针，它可以通过一级或二级间接存储，并从那里获取数据指针.

在previous examples 的基础上，天真的非 x64 兼容代码将是：

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

然后可以以以下非 x64 兼容方式使用：

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

请注意，我不确定c("A") 每次都返回相同的实际数据，而不是随意复制，因此可能不建议以这种方式缓存指针，您最好先保存将c("A") 的结果放入一个变量中，然后调用GetPointerToData 关闭该变量。

显然这应该重写为使用LongPtr 和CopyMemory，我可能明天会这样做，但你明白了。

Answer 2

如果将两个基本变量都视为 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

还可以查看这些有用的链接

Partial Arrays by reference

Copy an array reference in VBA

How do I slice an array in Excel VBA?

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