在 VBA 中复制没有引用的对象

Question

我在使用 VBA 中的对象变量时遇到问题。是否可以只复制对象变量而无需任何引用？

这里是类模块“clstest”

Option Explicit

Public x As Single

这是我的潜艇：

Sub CopyWithoutReference()

Dim standard As New clstest
Set standard = New clstest

Dim different As New clstest

standard.x = 20

Set different = standard
different.x = 30

MsgBox "I want standard.x to be 20 and not 30"
MsgBox standard.x
MsgBox different.x

我希望 standard.x 保持其值，并且如果 different.x 发生变化，则不会发生变化。 我在这里读到这篇文章： https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/set-statement 它说：

“因为这些变量是对对象的引用而不是对象的副本，所以对象的任何变化都会反映在引用它的所有变量中。”

但我不知道如何避免这个问题。有谁知道如何帮助我？

Answer 1

你可以在类中添加一个clone 方法，所以我有

我的班级

Public x As Integer

Public Function Clone() As Class1
    Set Clone = New Class1
    Clone.x = x
End Function

我的模块

Sub a()

Dim o As Class1
Dim o2 As Class1

Set o = New Class1
o.x = 20

Set o2 = o.Clone
o2.x = 500

Debug.Print o.x, o2.x

End Sub

------------------- 一次复制所有想法 ---------------------

新课程

Public Properties_ As Scripting.Dictionary

Private Sub Class_Initialize()
    Set Properties_ = New Scripting.Dictionary
End Sub

Public Sub Set_Property(strPropertyName As String, varProperty As Variant)
    If Properties_.Exists(strPropertyName) Then
        Properties_(strPropertyName) = varProperty
    Else
        Properties_.Add strPropertyName, varProperty
    End If
End Sub

Public Function Clone_() As Class1

    Set Clone_ = New Class1

    For i = 0 To Properties_.Count - 1
        Clone_.Set_Property CStr(Properties_.Keys()(i)), Properties_.Items()(i)

    Next i

End Function

新模块

Public Sub x()

Dim o1 As Class1
Dim o2 As Class1

Set o1 = New Class1

o1.Set_Property "Date", Now
o1.Set_Property "Name", "Test Name"

Set o2 = o1.Clone_

o2.Set_Property "Date", DateSerial(2000, 1, 1)

Debug.Print o1.Properties_("Date"), o2.Properties_("Date")

End Sub

Answer 2

This answer about VB6 is pretty good，memento pattern的实现以及VBA中通过类型引用属性的方式，实现了属性的复制。

---

创建了具有属性Salary、Age 和RelevantExperience 的Employee 类型的对象。然后创建一个新对象，使用函数.Copy 复制旧对象。新对象最初具有相同的属性，但我们可以选择更改其中的一些属性。在下面的代码中，Experience和Age发生了变化，Salary没有被提及，因此保持不变：

Dim newEmp As Employee
Dim oldEmp As Employee

Set newEmp = New Employee
With newEmp
    .Salary = 100
    .Age = 22
    .RelevantExperience = 1
End With

Set oldEmp = newEmp.Copy
With oldEmp
    'Salary is the same as in the NewEmp
    .Age = 99
    .RelevantExperience = 10
End With

这是结果：

当新员工被复制时，新员工“继承”的薪水相同。经历和年龄不同。

全面实施

在一个模块中：

Type MyMemento
    Salary As Double
    Age As Long
    RelevantExperience As Long
End Type

Sub Main()

    Dim newEmp As Employee
    Dim oldEmp As Employee

    Set newEmp = New Employee
    With newEmp
        .Salary = 100
        .Age = 22
        .RelevantExperience = 1
    End With

    Set oldEmp = newEmp.Copy
    With oldEmp
        'Salary is inherited, thus the same
        .Age = 99
        .RelevantExperience = 10
    End With

    Debug.Print "Salary"; vbCrLf; newEmp.Salary, oldEmp.Salary
    Debug.Print "Experience"; vbCrLf; newEmp.RelevantExperience, oldEmp.RelevantExperience
    Debug.Print "Age"; vbTab; vbCrLf; newEmp.Age, oldEmp.Age

End Sub

在一个名为Employee的类模块中：

Private Memento As MyMemento

Friend Sub SetMemento(NewMemento As MyMemento)
    Memento = NewMemento
End Sub

Public Function Copy() As Employee
    Dim Result As Employee
    Set Result = New Employee        
    Result.SetMemento Memento
    Set Copy = Result        
End Function

Public Property Get Salary() As Double
    Salary = Memento.Salary
End Property    
Public Property Let Salary(value As Double)
    Memento.Salary = value
End Property

Public Property Get Age() As Long
    Age = Memento.Age
End Property    
Public Property Let Age(value As Long)
    Memento.Age = value
End Property

Public Property Get RelevantExperience() As Long
    RelevantExperience = Memento.RelevantExperience
End Property    
Public Property Let RelevantExperience(value As Long)
    Memento.RelevantExperience = value
End Property