是否可以从集合中的子项访问父属性？

Question

我已经尽可能多地进行了研究，但从未为 VBA 找到明确的答案。

这篇较旧的 StackOverflow 帖子几乎包含所有内容，但不完全。VBA 类 - 如何让一个类拥有额外的类

底线 - 我有一个类 CClock，它是 CContacts 集合的父类，它是 CContact 的父类。

有什么办法可以从 CContact 获取 Clock 类的属性。所以像Debug.Print , clsContact.Parent.Parent.Lawyer下面的代码？

我试过按照我认为应该设置的方式设置父母，但几乎立即在Set clsClock = New CClock. 当我遵循代码时，它会转到 Contacts 集合中的类终止事件，我无法弄清楚。（尽管这可能是出现以下错误的原因。）

91 - Object Variable or With Variable not set

各种课程和快速测试装备如下（均基于 Dick Kusleika 在链接中的帖子。）谢谢。

（编辑 - 添加了测试例程，哎呀）

Sub test()

    Dim i As Long, j As Long
    Dim clsClocks As CClocks
    Dim clsClock As CClock
    Dim clsContact As CContact

    Set clsClocks = New CClocks

    For i = 1 To 3
        Set clsClock = New CClock
        clsClock.Lawyer = "lawyer " & i
        For j = 1 To 3
            Set clsContact = New CContact
            clsContact.ContactName = "Business Contact " & i & "-" & j
            clsClock.Contacts.Add clsContact
        Next j
        clsClocks.Add clsClock
    Next i

    For i = 1 To 2
        Set clsContact = New CContact
        clsContact.ContactName = "Business Contact 66" & "-" & i
        clsClocks(2).Contacts.Add clsContact
    Next i

    'write the data backout again
    For Each clsClock In clsClocks
        Debug.Print clsClock.Lawyer
        For Each clsContact In clsClock.Contacts
            Debug.Print , clsContact.ContactName
            Debug.Print , clsContact.Parent.Parent.Lawyer

        Next clsContact
    Next clsClock


End Sub

类 Clocks

'CClocks
Option Explicit
Private mcolClocks As Collection
Private Sub Class_Initialize()
    Set mcolClocks = New Collection
End Sub
Private Sub Class_Terminate()
    Set mcolClocks = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolClocks.[_NewEnum]
End Property
Public Sub Add(clsClock As CClock)
    If clsClock.ClockID = 0 Then
        clsClock.ClockID = Me.Count + 1
    End If

    Set clsClock.Parent = Me
    mcolClocks.Add clsClock, CStr(clsClock.ClockID)
End Sub
Public Property Get Clock(vItem As Variant) As CClock
    Set Clock = mcolClocks.Item(vItem)
End Property
Public Property Get Count() As Long
    Count = mcolClocks.Count
End Property
Public Sub Remove(vItem As Variant)
        clsClock.Remove vItem
End Sub
Public Sub Clear()
        Set clsClock = New Collection
End Sub

类 Clock

'CClock
Private mlClockID As Long
Private msLawyer As String
Private mlParentPtr As Long
Private mclsContacts As CContacts
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)
Public Property Set Contacts(ByVal clsContacts As CContacts): Set mclsContacts = clsContacts: End Property
Public Property Get Contacts() As CContacts: Set Contacts = mclsContacts: End Property
Public Property Let ClockID(ByVal lClockID As Long): mlClockID = lClockID: End Property
Public Property Get ClockID() As Long: ClockID = mlClockID: End Property
Public Property Let Lawyer(ByVal sLawyer As String): msLawyer = sLawyer: End Property
Public Property Get Lawyer() As String: Lawyer = msLawyer: End Property
Public Property Get Parent() As CClocks: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CClocks): mlParentPtr = ObjPtr(obj): End Property
Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function
Private Sub Class_Initialize()
    Set mclsContacts = New CContacts
    Set Me.Contacts.Parent = Me
End Sub
Private Sub Class_Terminate()
    Set mclsContacts = Nothing
End Sub
'CContacts
Option Explicit
Private mcolContacts As Collection
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)
Public Property Get Parent() As CClock: Set Parent = ObjFromPtr(mlParentPtr): End Property
Private Sub Class_Initialize()
    Set mcolContacts = New Collection
End Sub
Private Sub Class_Terminate()
    Set mcolContacts = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolContacts.[_NewEnum]
End Property
Public Sub Add(clsContact As CContact)
    If clsContact.ContactID = 0 Then
        clsContact.ContactID = Me.Count + 1
    End If
    Set clsContact.Parent = Me
    mcolContacts.Add clsContact, CStr(clsContact.ContactID)
End Sub
Public Property Get Clock(vItem As Variant) As CContact
    Set Clock = mcolContacts.Item(vItem)
End Property
Public Property Get Count() As Long
    Count = mcolContacts.Count
End Property
Public Sub Remove(vItem As Variant)
        clsContact.Remove vItem
End Sub
Public Sub Clear()
        Set clsContact = New Colletion
End Sub
Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

C类联系人

'CContact
Private mlContactID As Long
Private msContactName As String
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)

Public Property Let ContactID(ByVal lContactID As Long): mlContactID = lContactID: End Property
Public Property Get ContactID() As Long: ContactID = mlContactID: End Property
Public Property Let ContactName(ByVal sContactName As String): msContactName = sContactName: End Property
Public Property Get ContactName() As String: ContactName = msContactName: End Property
Public Property Get Parent() As CContacts: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CContacts): mlParentPtr = ObjPtr(obj): End Property
Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

Answer 1

如果您知道如何访问内核内存来执行此操作，请告诉我。看一下vbWatchDog的源码的源代码以获得一些提示。我一直在研究它以尝试访问调用堆栈。我还没弄清楚。

我会告诉你如何伪造它。我将稍微简化一下。您需要将该原则应用到您自己的代码中。这个技巧有点丑陋。它要求我们Initialize每次创建新的子对象时都调用一个例程

家长班：

'Class Parent
Option Explicit

Private mName as String
Public Property Get Name() as String
    Name = mName()
End Property

Public Property Let Name(value As String)
    mName = value
End Property

儿童班

'Class Child
Option Explicit

Private mParent as Parent    

Public Property Get Parent() as Parent
    Set Parent = mParent
End Property

Public Property Let Name(Obj as Parent)
    Set mParent = Obj
End Property

Public Sub Initialize(Obj as Parent)
    Set Me.Parent = Obj
End Sub

创建子对象：

Sub CreateChild()
    Dim parentObject As New Parent
    ' create child object with parent property
    Dim childObject As New Child
    childObject.Initialize(parentObject)
End Sub