excel - 是否可以从集合中的 child Access 父属性？

Question

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

这篇较旧的 StackOverflow 帖子几乎包含所有内容，但并不完全。 VBA Classes - How to have a class hold additional classes

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

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

我已经尝试按照我的想法设置 parent ，但几乎立即在 Set clsClock = New CClock 处得到以下错误.当我遵循代码时，它会转到 Contacts 集合中的类终止事件，我无法弄清楚。 (尽管这可能是出现以下错误的原因。)

91 - Object Variable or With Variable not set

下面是各种类(class)和快速测试装置(均基于链接中的 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

类 CClocks

'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

CClock类

'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

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

我会告诉你如何伪造它。我将简化一下。您需要将该原则应用于您自己的代码。诀窍有点丑陋。它要求我们调用 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

child 类

'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