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

Question

Есть ли способ скопировать ссылку на массив в VBA (или VB6)?

В VBA массивы являются типами значений. Присвоение одной переменной массива другой копирует весь массив. Я хочу, чтобы две переменные массива указывали на один и тот же массив. Есть ли способ сделать это, возможно, используя некоторые функции памяти API и / или VarPtr функция, которая на самом деле возвращает адрес переменной в VBA?

Dim arr1(), arr2(), ref1 As LongPtr
arr1 = Array("A", "B", "C")

' Now I want to make arr2 refer to the same array object as arr1
' If this was C#, simply assign, since in .NET arrays are reference types:
arr2 = arr1

' ...Or if arrays were COM objects:
Set arr2 = arr1

' VarPtr lets me get the address of arr1 like this:
ref1 = VarPtr(arr1)

' ... But I don't know of a way to *set* address of arr2.

Кстати, можно получить несколько ссылок на один и тот же массив, передав одну и ту же переменную массива ByRef нескольким параметрам метода:

Sub DuplicateRefs(ByRef Arr1() As String, ByRef Arr2() As String)
    Arr2(0) = "Hello"
    Debug.Print Arr1(0)
End Sub

Dim arrSource(2) As String
arrSource(0) = "Blah"

' This will print 'Hello', because inside DuplicateRefs, both variables
' point to the same array. That is, VarPtr(Arr1) == VarPtr(Arr2)
Call DuplicateRefs(arrSource, arrSource)

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

Answer 1

Да, вы можете, если обе переменные имеют тип Variant.

И вот почему: тип Variant сам по себе является оберткой. Фактическое битовое содержание варианта составляет 16 байтов. Первый байт указывает фактический тип данных, сохраненный в данный момент. Значение точно соответствует перечислению VbVarType. Т.е. если Variant в настоящий момент содержит значение Long, первый байт будет 0x03, значение vbLong, Второй байт содержит несколько битовых флагов. Например, если вариант содержит массив, бит в 0x20 в этом байте будет установлен.

Использование оставшихся 14 байтов зависит от типа хранимых данных. Для любого типа массива он содержит адрес массива.

Это означает, что если вы перезаписываете значение одного варианта, используя RtlMoveMemory вы фактически перезаписали ссылку на массив. Это на самом деле работает!

Есть одно предостережение: когда переменная массива выходит из области видимости, среда выполнения VB освобождает память, содержащуюся в фактических элементах массива. Когда вы вручную продублировали ссылку на массив с помощью техники Variant CopyMemory, которую я только что описал, в результате среда выполнения попытается восстановить ту же самую память дважды, когда оба варианта выйдут из области видимости, и программа потерпит крах. Чтобы избежать этого, вам нужно вручную "стереть" все ссылки, кроме одной, снова переписав вариант, например, с 0, прежде чем переменные выйдут из области видимости.

Пример 1. Это работает, но завершится сбоем, когда обе переменные выйдут из области видимости (при выходе из подпрограммы)

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

Sub CopyArrayRef_Bad()
    Dim v1 As Variant, v2 As Variant
    v1 = Array(1, 2, 3)
    CopyMemory v2, v1, 16

    ' Proof:
    v2(1) = "Hello"
    Debug.Print Join(v1, ", ")

    ' ... and now the program will crash
End Sub

Пример 2: С тщательной очисткой вы можете сойти с рук!

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)

Sub CopyArrayRef_Good()
    Dim v1 As Variant, v2 As Variant
    v1 = Array(1, 2, 3)
    CopyMemory v2, v1, 16

    ' Proof:
    v2(1) = "Hello"
    Debug.Print Join(v1, ", ")

    ' Clean up:
    FillMemory v2, 16, 0

    ' All good!
End Sub

Answer 2

Хотя вы можете использовать CopyMemory и FillMemory, Я настоятельно рекомендую вам никогда не хранить эти ссылки слишком долго. В качестве примера я сделал stdRefArrayкласс, основанный именно на этом принципе, НЕ ИСПОЛЬЗУЙТЕ ЭТОТ КОД! Прочтите, чтобы узнать, почему...:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "stdRefArray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'I STRONGLY RECOMMEND AGAINST USING THIS CLASS. SEE WHY HERE:
'https://stackru.com/a/63838676/6302131

'Status WIP
'High level wrapper around 2d array.

#Const DEBUG_PERF = False

'Variables for pData
Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)


Public Data As Variant

Private Const VARIANT_SIZE As Long = 16

Public Function Create(ByRef Data As Variant) As stdRefArray
    Set Create = New stdRefArray
    Call Create.Init(Data)
End Function
Public Sub Init(ByRef DataIn As Variant)
    'Create direct reference to array:
    CopyMemory Data, DataIn, VARIANT_SIZE
End Sub

Private Sub Class_Terminate()
   'Clean up array reference
   FillMemory Data, VARIANT_SIZE, 0
End Sub

Public Function GetData(ByVal iRow as long, ByVal iCol as long) as Variant
  Attribute GetData.VB_UserMemID=0
  GetData = GetData(iRow,iCol)
End Function

Моя первоначальная идея использования этого класса заключалась в следующем:

Cars.FindCar(...).GetDoor(1).Color = Rgb(255,0,0)

где класс Car имеет ссылку на массив Cars, и аналогично с классом Door хранится ссылка на массив Cars, что позволяет "мгновенно" установить параметры прямо к источнику начальных данных.

Это прекрасно работает! Но...

Я столкнулся с серьезными проблемами при отладке. Если вы находитесь в режиме отладки, в классе Door, в установщике цвета, если вы вносите изменения в структуру, которая потребует перекомпиляции IE Измените имя dimed, измените имя метода / свойства или измените их типы, Excel мгновенно выйдет из строя. То же самое произойдет, когда вы нажмете кнопку остановки VBA (квадрат). Не только это, но и отлаживать эти мгновенные сбои из Excel крайне неприятно...

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

Если вы когда-нибудь сделаете эти ссылки на массивы, убедитесь, что их жизнь будет невероятно короткой, и адекватно прокомментируйте между ними проблемы отладки.

Примечание. Если кто-нибудь сможет найти способ обойти эту проблему сбоя (т.е. правильно очистить стек до сбоя VBA, мне было бы очень интересно!)

Вместо этого я настоятельно рекомендую вам использовать такой простой класс:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "stdRefArray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Status WIP
'High level wrapper around arrays
Public Event Changed(ByVal iRow As Long, ByVal iCol As Long, ByVal Value As Variant)
Public vData As Variant

Public Function Create(ByRef Data As Variant) As stdRefArray
    Set Create = New stdRefArray
    Call Create.Init(Data)
End Function
Public Sub Init(ByRef Data As Variant)
    'Slow, but a stable reference
    vData = Data
End Sub



Public Property Get Data(Optional ByVal iRow As Long = -1, Optional ByVal iCol As Long = -1) As Variant
Attribute Data.VB_UserMemId = 0
    If iRow = -1 And iCol = -1 Then
        CopyVariant Data, vData
    ElseIf iRow <> -1 And iCol <> -1 Then
        CopyVariant Data, vData(iRow, iCol)
    Else
        stdError.Raise "stdRefArray::Data() - Invalid use of Data", vbCritical
    End If
End Property
Public Property Let Data(ByVal iRow As Long, ByVal iCol As Long, Value As Variant)
    vData(iRow, iCol) = Value
    RaiseEvent Changed(iRow, iCol, Value)
End Property
Public Property Set Data(ByVal iRow As Long, ByVal iCol As Long, Value As Object)
    Set vData(iRow, iCol) = Value
    RaiseEvent Changed(iRow, iCol, Value)
End Property
Public Property Get BoundLower(ByVal iDimension As Long) As Long
    BoundLower = LBound(vData, iDimension)
End Property
Public Property Get BoundUpper(ByVal iDimension As Long) As Long
    BoundUpper = UBound(vData, iDimension)
End Property


Private Function CopyVariant(ByRef dest As Variant, ByVal src As Variant)
    If IsObject(src) Then
        Set dest = src
    Else
        dest = src
    End If
End Function

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

Применение, Car.cls:

Private WithEvents pInventory as stdRefArray
Public Function Create(ByRef arrInventory as variant)
   Set Create = new Car
   Set Create.pInventory = stdRefArray.Create(arrInventory)
End Function
Public Function GetDoor(ByVal iRow as long) as Door
   Set GetDoor = new Door
   GetDoor.init(pInventory,iRow)
End Function

Door.cls

Private pArray as stdRefArray
Private pRow as long
Private Const iColorColumn = 10
Sub Init(ByVal array as stdRefArray, ByVal iRow as long)
    set pArray = array
    pRow = iRow
End Sub
Public Property Get Color() as long
    Color = pArray(pRow,iColorColumn)
End Property
Public Property Let Color(ByVal iNewColor as long)
    pArray(pRow,iColorColumn) = iNewColor
End Property

Пример, вероятно, не слишком хорош, lol, но, надеюсь, вы уловили идею.

Answer 3

Вы можете использовать метод, называемый GetArrayByRefиз моего репозитория VBA-MemoryTools. Однако, если вам не нужна дополнительная ссылка, вы можете использовать этот ограниченный, более медленный код:

      Option Explicit

#If Mac Then
    #If VBA7 Then
        Public Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
    #Else
        Public Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
    #End If
#Else 'Windows
    'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
    #If VBA7 Then
        Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    #End If
#End If

Public Const VT_BYREF As Long = &H4000
#If Win64 Then
    Public Const PTR_SIZE As Long = 8
#Else
    Public Const PTR_SIZE As Long = 4
#End If

Public Function GetArrayByRef(ByRef arr As Variant) As Variant
    If IsArray(arr) Then
        GetArrayByRef = VarPtrArr(arr)
        Dim vt As VbVarType: vt = VarType(arr) Or VT_BYREF
        CopyMemory GetArrayByRef, vt, 2
    Else
        Err.Raise 5, "GetArrayByRef", "Array required"
    End If
End Function

#If Win64 Then
Public Function VarPtrArr(ByRef arr As Variant) As LongLong
#Else
Public Function VarPtrArr(ByRef arr As Variant) As Long
#End If
    Const vtArrByRef As Long = vbArray + VT_BYREF
    Dim vt As VbVarType
    CopyMemory vt, arr, 2
    If (vt And vtArrByRef) = vtArrByRef Then
        Const pArrayOffset As Long = 8
        CopyMemory VarPtrArr, ByVal VarPtr(arr) + pArrayOffset, PTR_SIZE
    Else
        Err.Raise 5, "VarPtrArr", "Array required"
    End If
End Function

Быстрый тест:

      Sub Demo()
    Dim arr() As String
    ReDim arr(1 To 2)
    arr(1) = "AAA"
    
    Dim v As Variant
    
    v = GetArrayByRef(arr)
    v(2) = "BBB"
    
    Debug.Assert arr(2) = "BBB"
End Sub

Это также безопасно — вам не нужно беспокоиться об освобождении памяти.

Answer 4

Как насчет этого решения...

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

Public Sub TRIAL()
Dim myValueType As Integer
Dim mySecondValueType As Integer
Dim memPTR As Long

myValueType = 67
memPTR = VarPtr(mySecondValueType)
CopyMemory ByVal memPTR, myValueType, 2
Debug.Print mySecondValueType
End Sub

Концепция взята из статьи CodeProject здесь

Answer 5

А что насчёт создания обёртки? Как и этот модуль класса "MyArray" (упрощенный пример):

Private m_myArray() As Variant

Public Sub Add(ByVal items As Variant)
    m_myArray = items
End Sub

Public Sub Update(ByVal newItem As String, ByVal index As Integer)
    m_myArray(index) = newItem
End Sub

Public Function Item(ByVal index As Integer) As String
    Item = m_myArray(index)
End Function

Тогда в стандартном модуле:

Sub test()
    Dim arr1 As MyArray
    Dim arr2 As MyArray

    Set arr1 = New MyArray
    arr1.Add items:=Array("A", "B", "C")

    Set arr2 = arr1

    arr1.Update "A1", 0

    Debug.Print arr1.Item(0)
    Debug.Print arr2.Item(0)
End Sub

Это помогает?