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

-------------------在一次想法中复制ALLL ---------------------

新班

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复制旧对象。新对象最初具有相同的属性，但是我们可以选择更改其中一些属性。在体验和年龄下面的代码中，未提及薪金，因此保持不变：

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

复制对象而不在VBA中引用

2 个答案: