18

有没有办法在 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)

但这仍然不允许人们简单地制造与现有参考相同范围的新参考。

4

4 回答 4

22

是的，如果两个变量都是 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
于 2013-05-02T17:10:52.087 回答
1

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

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

于 2013-05-01T19:03:34.607 回答
0

尽管您可以使用CopyMemoryand 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 类中，在颜色设置器中，如果您对需要重新编译的结构进行更改 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

这个例子可能不太好，哈哈，但希望你能明白。

于 2020-09-10T22:56:58.337 回答
0

您可以使用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

它也很安全——你不必担心内存释放

于 2022-02-11T14:08:30.503 回答