Question

我尽可能多地研究，并且从未在VBA上找到明确的答案。

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

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

有没有办法从CContact获取CClock类的属性。在下面的代码中有类似Debug.Print , clsContact.Parent.Parent.Lawyer的内容吗？

我已经尝试按照我认为应该设置的父母，但几乎立即在Set clsClock = New CClock得到以下错误。当我按照代码进入联系人集合中的类终止事件时，我无法弄清楚。（虽然这可能是下面的错误出现的原因。）

91 - Object Variable or With Variable not set

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

（编辑 - 添加测试程序，whooopsy）

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

等级CContact

'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

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

1 个答案: