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

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

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

底线-我有一个CClock类，它是CContacts集合的父级，而CContacts是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

Clas 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

最佳答案

如果您知道如何 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

子类

'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