vba deep copy/clone issue with class object dictionary - vba

I have a dictionary in my Main Sub (KEY = string; VALUE = Class Object). The Class Object consists of two dictionaries. As I collect data and check the values stored in the Dictionary Values (Class Object - dictionaries) I noticed that only the last values are getting stored. What I mean is that all the Values in my dictionary in my Main Sub are pointing to the same dictionary reference, hence, all the instances of my Class Objects contain the same data. This means that I need to make a clone of my Class Objects (deep copy?). I have successfully done this before with Class Objects that only stored simple values, but not with dictionaries. I need help cloning my Class Object that contains dictionaries.
MAIN SUB
Dim dGroup As New Scripting.Dictionary ' Main Dictionary
'
' loop thru a listbox
For i = 0 To UserForm1.ListBox1.ListCount - 1
Gname = UserForm1.ListBox1.List(i) ' get listbox names
' populate temp dictionary
Set dic = FNC.GET_SESSION_FILE_ELEMENTS(mySesFile, Gname)
'
' instantiate new Class Object
Dim NewCol As New cVM_Col
Call NewCol.INIT(dic) ' pass the dictionary to a 'constructor'
dGroup.Add Gname, NewCol.CLONE ' add to the MAIN SUB dictionary
'
Set dic = Nothing ' clear the temp dictionary
Next i
CLASS OBJECT
Private dElms As Scripting.Dictionary
Private dDat As Scripting.Dictionary
'
Private Sub Class_Initialize()
Set dElms = New Scripting.Dictionary
Set dDat = New Scripting.Dictionary
End Sub
'
Public Sub INIT(inp As Scripting.Dictionary)
Set dElms = inp
End Sub
'
Public Function CLONE()
Set CLONE = New cVM_Col
Set CLONE.dElms = dElms ' <-- THIS IS WHERE IT CRASHES
Set CLONE.dDat = dDat
End Function
Normally my CLONE function works when I am only cloning simple data types like String or Long or Double. I've never had to do this with a Dictionary.

To CLONE the dictionary objects in my CLASS Objects I had to make the following changes:
CLASS OBJECT
(Modified CLONE function)
Public Function CLONE()
Set CLONE = New cVM_Col
CLONE.Elms = dElms
CLONE.Dat = dDat
End Function
(Added Properties)
Public Property Get Elms() As Scripting.Dictionary
Set Elms = dElms
End Property
Public Property Let Elms(p As Scripting.Dictionary)
Set dElms = p
End Property
'
Public Property Get Dat() As Scripting.Dictionary
Set Dat = dDat
End Property
Public Property Let Dat(p As Scripting.Dictionary)
Set dDat = p
End Property

Related

Nested VBA collection of classes returning "Argument not optional" error

I am trying to represent the idea of nested classes with collections of child classes with the natural example of Grandmother - Married Daughters - Little kids case, so I have 3 classes as following:
' Class GrandMother:
Private pMarriedDaughter As Collection
Public Property Get MarriedDaughter() As Collection
MarriedDaughter = pMarriedDaughter
End Property
Public Property Set MarriedDaughter(C As Collection)
Set pMarriedDaughter = C
End Property
' Class MarriedMom:
Private pChildren As Collection
Public Property Get Children() As Collection ' ERROR HERE!
Children = pChildren
End Property
Public Property Set Children(C As Collection)
Set pChildren = C
End Property
' Child Class:
Private pName As String
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(s As String)
Let pName = s
End Property
And the Main Routine that tries to populate the classes:
Sub TestGrandMother()
' Create 3 Childs
Dim Child_1a As New Child: Child_1a.Name = "Bill"
Dim Child_1b As New Child: Child_1b.Name = "Sam"
Dim Child_2a As New Child: Child_2a.Name = "Sahar"
' Create 2 Married Daughters:
Dim Mamy1 As New MarriedMom
Dim Mamy2 As New MarriedMom
' Add the the children to the married daughters
Set Mamy1.Children = New Collection
Mamy1.Children.Add Child_1a
Mamy1.Children.Add Child_1b
Set Mamy2.Children = New Collection
Mamy2.Children.Add Child_2a
' Create Grandmother
Dim GrandMa As GrandMother: Set GrandMa = New GrandMother
Set GrandMa.MarriedDaughter = New Collection
GrandMa.MarriedDaughter.Add Mamy1
GrandMa.MarriedDaughter.Add Mamy2
' Now cycle childs Name and debug:
Dim aChild As New Child
For Each aChild In GrandMa.MarriedDaughter.Children
Debug.Print GrandMa.MarriedDaughter.Children.Name
Next aChild
End Sub
In both cases where that error occurs you need to use the Set keyword as working with an object. That is just for the error type you comment on.
e.g.
Set Children = pChildren
Set MarriedDaughter = pMarriedDaughter
The following GrandMa.MarriedDaughter does not expose a .Children btw.
Perhaps
Dim aChild As MarriedMom, nextChild As Child
For Each aChild In GrandMa.MarriedDaughter
For Each nextChild In aChild.Children
Debug.Print nextChild.Name
Next
Next aChild

Adding a custom class collection to another custom class collection

Ok to start off, I read through this.
It is close although it doesn't answer my specific question. This talks about taking smaller collections and adding items to a larger main collection. Then destroying the smaller collection.
I have two definitions under Class Modules.
TimeDet
Option Explicit
Public recDate As String
Public recQty As String
Public recDieNo As String
Public recCatID As String
Public recCatName As String
Public recGroupID As String
Public recGroupName As String
TimeRec
Option Explicit
Private objTimeRec As Collection
Private Sub Class_Initialize()
Set objTimeRec = New Collection
End Sub
Private Sub Class_Terminate()
Set objTimeRec = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = objTimeRec.[_NewEnum]
End Property
Public Sub Add(obj As TimeDet)
objTimeRec.Add obj
End Sub
Public Sub Remove(Index As Variant)
objTimeRec.Remove Index
End Sub
Public Property Get Item(Index As Variant) As TimeDet
Set Item = objTimeRec.Item(Index)
End Property
Property Get Count() As Long
Count = objTimeRec.Count
End Property
Public Sub Clear()
Set objTimeRec = New Collection
End Sub
Public Sub FillFromArray(Arr As Variant)
Dim i As Long, obj As TimeDet
For i = 1 To UBound(Arr)
Set obj = New TimeDet
obj.recDate = Arr(i, 1)
obj.recQty = Arr(i, 2)
obj.recDieNo = Arr(i, 3)
obj.recCatID = Arr(i, 4)
obj.recCatName = Arr(i, 5)
obj.recGroupID = Arr(i, 6)
obj.recGroupName = Arr(i, 7)
Me.Add obj
Next
End Sub
Then in the code I am using it this way:
Sub Test()
Dim RecSet1 As TimeRec, Record As TimeDet
Dim fSet1 As TimeRec, fRecord As TimeDet
Dim repArray() As Variant
Dim startDT As Date, endDT As Date, dieNo As String
repArray() = Sheet4.Range("A2:G" & Sheet4.Range("A2").End(xlDown).Row)
Set RecSet1 = New TimeRec
Set fSet1 = New TimeRec
RecSet1.FillFromArray (repArray())
startDT = "1-1-2015"
endDT = "1-1-2016"
dieNo = "16185"
For Each Record In RecSet1
If Record.recDate <= endDT And Record.recDate >= startDT And Record.recDieNo = dieNo Then
fSet1.Add (Record)
End If
Next
End Sub
I am getting an error when I try to add the Record object to the fSet1 object.
"Object doesn't support this method or property"
The Record object is Type TimeDet which as you can see up in the class module my Add method is expecting type TimeDet.
Either I am missing something very simple and have blinders on, or this is a bigger issue.
The array has 200,000 records roughly. I am attempting to create a smaller subset of filtered data. Maybe I am approaching this from the wrong way.
Your error is not at Add but at For Each
Most likely you copied your TimeRec Class. In VBA, you can't create enumerable classes inside the VBE (VBA IDE). There's a different way of creating Enumerable classes.
Open a notepad, copy all your class code and then add this attribute to NewEnum property Attribute NewEnum.VB_UserMemId = -4
Then import the class.
This is always hidden in VBA code, but can be seen in text editors.
Also add this attribute to Item property, it will make it default and allows syntax like ClassName(1)
Attribute Item.VB_UserMemId = 0
So , your code in text editor/ notepad should be:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private objTimeRec As Collection
Private Sub Class_Initialize()
Set objTimeRec = New Collection
End Sub
Private Sub Class_Terminate()
Set objTimeRec = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Set NewEnum = objTimeRec.[_NewEnum]
End Property
Public Sub Add(obj As Class2)
objTimeRec.Add obj
End Sub
Public Sub Remove(Index As Variant)
objTimeRec.Remove Index
End Sub
Public Property Get Item(Index As Variant) As Class2
Attribute Item.VB_UserMemId = 0
Set Item = objTimeRec.Item(Index)
End Property
Property Get Count() As Long
Count = objTimeRec.Count
End Property
Public Sub Clear()
Set objTimeRec = New Collection
End Sub
The answer to this particular problem was to remove the parenthesis form my Add method. That being said, the attribute info being hidden was really good info and would have probably contributed to the problem after I figured out that removing the parenthesis fixed it.

Setting dictionaries to properties

I'm not new to VBA but I am new to classes and I'm struggling at the moment with initialising some dictionaries.
Here's a cut down version of my class:
Option Explicit
'Variables required for object operations
Private pFilePath As String 'contains the file path of the TAB file.
...
Private pDATAFields As Object 'dictionary1
Private pMetadata As Object 'dictionary2
Private Sub Class_Initialize()
Set pDATAFields = CreateObject("Scripting.Dictionary")
Set pMetadata = CreateObject("Scripting.Dictionary")
End Sub
...
Public Property Get DATAFields() As Object
DATAFields = pDATAFields
End Property
Public Property Get Metadata() As Object
Metadata = pMetadata
End Property
'Methods required
Public Sub initialise(sFilePath As String)
'sTABText contains the text from file at sFilePath
Dim sTabText As String
sTabText = harvestTextFile(sFilePath)
...
pTABVersion = pullPart("Version", strArr(1), 1)
...
Set pDATAFields = generateFieldStructureDict(strArr, 6, 5 + pDATAFieldNumber)
...
'Generate the metadata dictionary from the file
Set pMetadata = generateMetadataDict(strArr, i + 1)
End Sub
Private Function generateFieldStructureDict(arg1 as string, arg2 as integer, arg3 as Integer) as Object
Dim oObj as Object
Set oObj = CreateObject("scripting.dictionary")
... do stuff
Set generateFieldStructureDict = oObj
End Function
... Similar function for generateMetadataDict
From my own observations this should work but for some reason it doesn't. The properties such as pTABVersion get set fine. It just appears to be pDATAFields and pMetadata which aren't getting set properly.
If I follow the function generateFieldStructureDict step by step I see that by the end of the function when I am doing:
set generateFieldStructureDict = oObj
this part works absolutely fine. The dictionary in oObj is passed onto generateFieldStructureDict. However when we then return to the initialise sub routine:
Set pDATAFields = generateFieldStructureDict(strArr, 6, 5 + pDATAFieldNumber)
generateFieldStructureDict appears to lose all the data I gave it. Ultimately clsTab.filePath and clsTab.tabVersion will return the pFilePath and pTabVersion (because they have been set). However clsTab.DATAFields and clsTab.Metadata will not return dictionaries like they are supposed to. This is because pMetadata and pDATAFields are not set for some reason.
Does anyone have any ideas as to what I need to do to get this working?

Accessing Items in a Collection from a Class

-EDIT Fixed
I was missing one thing and doing one thing wrong. First I was missing a function to access the collection by index. And I should of been using a for Loop instead of a for each loop in my module code
I forgot to add this to the collection class
Public Function GetPayRecords(ByVal index As Variant) As PayRecords
Set GetPayRecords = pObjCol.item(index)
End Function
and replaced
For Each vItem In .GetPayRecords
....code to do stuff
Next vItem
with this in the module
Dim x As Integer
For x = 1 To .Count
Debug.Print .GetPayRecords(x).PY_PayRecord.CEOCompanyID
Debug.Print .GetPayRecords(x).PY_PayRecord.OrigBankID
Next x
I'm writing a program that has 8 Classes. Each class represents a specific record type.
I have an overall Class that contains those 8 classes which is for simplicity when coding in the Module. I only have to declare one class which gives me access to all 8 classes. I have a collection which contains all the records types. Once all the logic of loading the individual records is complete they get added to the collection. This all works perfectly and I can see all the records in the collection. The final step, which happens to be where i'm having the problem, I need to extract each item within the collection by record type and write it to a csv. The problem I encounter is trying to iterate through each record.
Here's how the structure looks
Classes
clsAllRecordTypes
clsRecordType1
clsRecordType2
...
clsRecordType8
Collection
clsColRecords
The problem is in the retrieval
Module
Dim PayRecord As PayRecords 'Class of Classes
Dim PayRecordList As bankCollection
...code to load all the payrecords
With payrecordlist
Foreach vItem in .pObjCol
debug.print .pObjCol.Item(?) ' not sure why i can't see all 8
next vItem
End With
When I add vItem to the watch I can see each and every record type filled up with information but yet i Can not access it. Below is the Class of classes and collection
Class of Classes
Option Explicit
'This class is a representation of all the record types that apply to our Payment Manager
'It aggregates all the record types (classes) into one class. That one class is used in the main processing module for simplicty
'
Private pPayRecord As New PayRecord
Private pPNAR_OP As New PNAR_OP
Private pPNAR_RP As New PNAR_RP
Private pSuppACHREC As New SuppACHRec
Private pSuppCCRRec As New SuppCCRRec
Private pSuppCHKRec As New SuppCHKRec
Private pDocumentDelieveryRec As New DocumentDeliveryRecord
Private pInvoiceRecords As New InvoiceRecords
Public Property Get PY_PayRecord() As PayRecord
Set PY_PayRecord = pPayRecord
End Property
Public Property Let PY_PayRecord(ByVal newPayRecord As PayRecord)
Set pPayRecord = newPayRecord
End Property
Public Property Get PA_PNAR_OP() As PNAR_OP
Set PA_PNAR_OP = pPNAR_OP
End Property
Public Property Let PA_PNAR_OP(ByVal newPNAR_OP_Record As PNAR_OP)
Set pPNAR_OP = newPNAR_OP_Record
End Property
Public Property Get PA_PNAR_RP() As PNAR_RP
Set PA_PNAR_RP = pPNAR_RP
End Property
Public Property Let PA_PNAR_RP(ByVal newPNAR_RP_Record As PNAR_RP)
Set pPNAR_RP = newPNAR_RP_Record
End Property
Public Property Get AC_SuppACH() As SuppACHRec
Set AC_SuppACH = pSuppACHREC
End Property
Public Property Let AC_SuppACH(ByVal newSuppACH_Record As SuppACHRec)
Set pSuppACHREC = newSuppACH_Record
End Property
Public Property Get AC_SuppCCR() As SuppCCRRec
Set AC_SuppCCR = pSuppCCRRec
End Property
Public Property Let AC_SuppCCR(ByVal newSuppCCR_Record As SuppCCRRec)
Set pSuppCCRRec = newSuppCCR_Record
End Property
Public Property Get AC_SuppCHK() As SuppCHKRec
Set AC_SuppCHK = pSuppCHKRec
End Property
Public Property Let AC_SuppCHK(ByVal newSuppCHK_Record As SuppCHKRec)
Set pSuppCHKRec = newSuppCHK_Record
End Property
Public Property Get DocumentDeliveryRecord() As DocumentDeliveryRecord
Set DocumentDeliveryRecord = pDocumentDelieveryRec
End Property
Public Property Let DocumentDeliveryRecord(ByVal newDocumentDeliveryRecord As DocumentDeliveryRecord)
Set pDocumentDelieveryRec = newDocumentDeliveryRecord
End Property
Public Property Get InvoiceRecords() As InvoiceRecords
Set InvoiceRecords = pInvoiceRecords
End Property
Public Property Let InvoiceRecords(ByVal newInvoiceRecord As InvoiceRecords)
Set pInvoiceRecords = newInvoiceRecord
End Property
Collection Class
Option Explicit
Private pHeaderRec As New HeaderRec
Private pNewPayRecords As New PayRecords
Public pObjCol As Collection
Private pTrailerRec As New TrailerRec
Private Sub Class_Initialize()
Set pObjCol = New Collection
End Sub
Private Sub Class_Terminate()
Set pObjCol = Nothing
End Sub
Public Property Get HD_HeaderRecord() As HeaderRec
Set HD_HeaderRecord = pHeaderRec
End Property
Public Property Let HD_HeaderRecord(ByVal newHeaderRecord As HeaderRec)
Set pHeaderRec = newHeaderRecord
End Property
Sub Add(ByVal newPayRecs As PayRecords)
pObjCol.Add newPayRecs
End Sub
Property Get Count() As Long
Count = pObjCol.Count
End Property
Public Property Get TR_TrailerRecord() As TrailerRec
Set TR_TrailerRecord = pTrailerRec
End Property
Public Property Let TR_TrailerRecord(ByVal newTrailer_Record As TrailerRec)
Set pTrailerRec = newTrailer_Record
End Property
I'm sorry if this doesn't help, because your explanation is hard to follow. But, I'll assume that you are saying that you have an object of type Payrecords, which contains references to seven other objects of types PNAR_OP, PNAR_RP, etc. Each of these latter objects contain "20-30 fields" that you want to get at. You ask how to loop through all of these.
A simple way to do that is to use an array. Yes, you can foreach through Collections or (better yet) Dictionaries, but arrays work, they're easy to understand, and they were iterating through objects when Collections were running around in diapers.
Let your Payrecords have a property of type Object(6). When you initialize it, instantiate one of each of the seven objects and add it to the array (for example, "Set myPayrecordsObjects(3) = New SubCCRRec" and so on). To loop through, just use a for next loop to loop through the 7 objects.
Since you provide no information about how you structure your "fields" within these objects, I'll recommend that you iterate through the Fields collection of the ADO object to loop through those. (If you're not using the ADO Fields collection, well, your attention to detail gets mine in return.)

Extend Collections Class VBA

I have created a sort function to allow a collection of instances of a custom object to be sorted based on one of the objects properties. Is it possible to extend the existing collections class in VBA? I do not believe inheritance is supported in VBA, so I am not sure how to go about this in the proper way. I could just create a new module and place the function in that module, but that doesn't seem like the best way of doing it.
Thanks for the responses. I ended up creating my own class which extends the Collections class in VBA. Below is the code if anyone is interested.
'Custom collections class is based on the Collections class, this class extendes that
'functionallity so that the sort method for a collection of objects is part of
'the class.
'One note on this class is that in order to make this work in VBA, the Attribute method has to be added
'manually. To do this, create the class, then export it out of the project. Open in a text editor and
'add this line Attribute Item.VB_UserMemId = 0 under the Item() function and this line
'Attribute NewEnum.VB_UserMemId = -4 under the NewEnum() function. Save and import back into project.
'This allows the Procedure Attribute to be recognized.
Option Explicit
Private pCollection As Collection
Private Sub Class_Initialize()
Set pCollection = New Collection
End Sub
Private Sub Class_Terminate()
Set pCollection = Nothing
End Sub
Function NewEnum() As IUnknown
Set NewEnum = pCollection.[_NewEnum]
End Function
Public Function Count() As Long
Count = pCollection.Count
End Function
Public Function item(key As Variant) As clsCustomCollection
item = pCollection(key)
End Function
'Implements a selection sort algorithm, could likely be improved, but meets the current need.
Public Sub SortByProperty(sortPropertyName As String, sortAscending As Boolean)
Dim item As Object
Dim i As Long
Dim j As Long
Dim minIndex As Long
Dim minValue As Variant
Dim testValue As Variant
Dim swapValues As Boolean
Dim sKey As String
For i = 1 To pCollection.Count - 1
Set item = pCollection(i)
minValue = CallByName(item, sortPropertyName, VbGet)
minIndex = i
For j = i + 1 To pCollection.Count
Set item = pCollection(j)
testValue = CallByName(item, sortPropertyName, VbGet)
If (sortAscending) Then
swapValues = (testValue < minValue)
Else
swapValues = (testValue > minValue)
End If
If (swapValues) Then
minValue = testValue
minIndex = j
End If
Set item = Nothing
Next j
If (minIndex <> i) Then
Set item = pCollection(minIndex)
pCollection.Remove minIndex
pCollection.Add item, , i
Set item = Nothing
End If
Set item = Nothing
Next i
End Sub
Public Sub Add(value As Variant, key As Variant)
pCollection.Add value, key
End Sub
Public Sub Remove(key As Variant)
pCollection.Remove key
End Sub
Public Sub Clear()
Set m_PrivateCollection = New Collection
End Sub
One popular option is to use an ADO disconnected recordset as a sort of hyperpowered collection/dictionary object, which has built-in support for Sort. Although you are using ADO, you don't need a database.
I would create a wrapper class that exposes the collection object's properties, substituting the sort function with your own.