![](/img/trans.png)
[英]Is it possible to reach the property of a collection object that is not part of an interface
[英]Is it possible to access a parent property from a child that is in a collection?
我已經盡可能多地進行了研究,但從未為 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
如果您知道如何訪問內核內存來執行此操作,請告訴我。 查看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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.