在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类型本身就是一个包装器。 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

这个解决方案怎么样......

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文章here

Answer 3

那要创建一个包装器呢？像这个类模块'Array'（简化示例）：

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

这有帮助吗？

Answer 4

尽管您可以使用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://stackoverflow.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类中的颜色设置器中，如果对结构进行更改，则需要重新编译I.E.更改dim变量的名称，更改方法/属性的名称，或更改其类型， 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

这个例子可能不太好笑，但希望您能理解。