Указатели на массивы, хранящиеся как элементы коллекции / словаря 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

Этот вид работает, но по какой-то причине безопасная структура массива (обернутая в тип данных Variant, аналогично массиву вариантов выше), возвращаемая col("A"), содержит только некоторые внешние атрибуты, такие как число измерений и затемненные границы, но указатель на сам 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 как это на самом деле хранится это блоб, вы получаете его во временную 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 на самом деле один и тот же "элемент" - это число, повторенное три раза является адресом временного VariantРазмером 16 байт, который создается для хранения элемента массива и который компилятор решил использовать повторно.

---

Вот почему элемент массива, возвращаемый таким способом, не может использоваться для арифметики указателей.

Сами коллекции ничего не добавляют к этой проблеме. Это факт, что коллекция должна обернуть данные, которые она хранит в Variant это портит это. Это может произойти и при сохранении массива в Variant в любом другом месте.

---

Чтобы получить действительный указатель на развернутые данные, подходящий для арифметики указателя, вам нужно запросить SAFEARRAY* указатель от Variantгде он может храниться с одним или двумя уровнями косвенности, и взять указатель данных оттуда.

Основываясь на предыдущих примерах, наивный не 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

Также посмотрите эти полезные ссылки

Частичные массивы по ссылке

Скопируйте ссылку на массив в VBA

Как мне нарезать массив в Excel VBA?

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