VBA Classes - How to have a class hold additional classes

Question

I have a challenge that I am trying to solve using classes.

I am logging transactions into a class.

Each transaction has the following:

• Name

Answer 1

There are a few things that don't do what you expect in your code. I have cleaned it a bit and this new version should be closer to what you want. Let me know if the changes are not self-explanatory.

Main procedure:

Sub test()

    Dim i As Long
    Dim j As Long

    'code to populate some objects
    Dim clocklist As Collection
    Dim clock As classClocks
    Dim businessContactList As Collection
    Dim businessContact As classBusinessContact

    Set clocklist = New Collection

    For i = 1 To 3
        Set businessContactList = New Collection
        Set clock = New classClocks
        clock.LawyerName = "lawyer " & i
        For j = 1 To 3
            Set businessContact = New classBusinessContact
            businessContact.Name = "Business Contact " & j
            businessContactList.Add businessContact
        Next j
        Set clock.BusinessContactAdd = businessContactList
        clocklist.Add clock
    Next i

    Set businessContactList = Nothing

    'write the data backout again
    For Each clock In clocklist
        Debug.Print clock.LawyerName
        Set businessContactList = clock.BusinessContacts
        For Each businessContact In businessContactList
            Debug.Print businessContact.Name
        Next

    Next

End Sub

classClocks:

Private pLawyerName As String
Private pBusinessContactList As Collection

Private Sub Class_Initialize()
  Set pBusinessContactList = New Collection
End Sub

Public Property Get LawyerName() As String
    LawyerName = pLawyerName
End Property

Public Property Let LawyerName(ByVal sLawyerName As String)
    pLawyerName = sLawyerName
End Property

Public Property Get BusinessContacts() As Collection
    Set BusinessContacts = pBusinessContactList
End Property

Public Property Set BusinessContactAdd(contactCollection As Collection)

    For Each contactName In contactCollection
        pBusinessContactList.Add contactName
    Next

End Property

Answer 2

I haven't done VBA for a while, but I noticed this line:

Public Property Set BusinessContactAdd(ByRef strName() As Collection) 

I think putting parentheses on a parameter name indicates that it's an array, which yours is not: it's a single instance of a collection.

Answer 3

I tend to make everything a class and chain the class calls together to access them. It's not a better way than the one that assylias posted, just different. And you may prefer it.

CClocks (collection class that's the parent of the CClock instances)

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

CClock class

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
End Sub

Private Sub Class_Terminate()
    Set mclsContacts = Nothing
End Sub

CContacts (parent class to CContact and a child to each CClock class)

Private mcolContacts As Collection

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 Contact(vItem As Variant) As CContact
    Set Contact = mcolContacts.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolContacts.Count
End Property

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

And the test procedure

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

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

End Sub

Instead of having Contacts as an integral part of CClock, I make it its own class/collection class. Then I can access like

clsClock.Contacts.Item(1).ContactName

And I can use CContacts somewhere else in my code if it comes up.

You can ignore the NewEnum and CopyMemory stuff or read about it here http://www.dailydoseofexcel.com/archives/2010/07/04/custom-collection-class/ and here http://www.dailydoseofexcel.com/archives/2007/12/28/terminating-dependent-classes/#comment-29661 Those two parts are so I can have a Parent property without worrying about garbage collection (CopyMemory and ObjPtr) and so I can For.Each through the class (NewEnum).