iterate custom dictionary object - vba

Recently learned a bit of object oriented in Python, and I'm trying to do the same things in VBA.
I manage to construct a parent object (PC) that contains a dictionary of children objects:hooks. Hooks is also an object with a dictionary of children: rows.
All I want to do it to be able to write:
for each hook in PC
for each row in hook
sheets("X").cells(i,1) = contract.price
next row
next hook
Im looking at this but can't make it work...
Here summary of classes:
Class PC
Option Explicit
Public pPC As Object
Private pName As String
Private pInclude As Boolean
Private Sub Class_Initialize()
Set pPC = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
Set pPC = Nothing
End Sub
Public Property Get hook(HookName As String) As CHook:
Set hook = pPC(HookName)
End Property
Public Sub Add(hook As CHook):
If Not pPC.exists(hook.Name) Then pPC.Add hook.Name, hook
End Sub
Public Property Get Include(HookName As String) As Boolean:
pInclude = pPC.exists(HookName)
Include = pInclude
End Property
Public Property Let Name(pcname As String):
pName = pcname
End Property
Public Property Get Name() As String:
Name = pName
End Property
Class Hook
Option Explicit
Public pHook As Object
Private pName As String
Private pLTFlatPrice As Double
Private pLTBasisPrice As Double
Private pLTDate As Date
Private Sub Class_Initialize()
Set pHook = CreateObject("Scripting.Dictionary")
pLTDate = Sheets("Control").Cells(2, 2)
End Sub
Private Sub Class_Terminate()
Set pHook = Nothing
End Sub
Public Sub AddRow(Row As CRow)
If Not pHook.exists(Row.ContractLot) Then pHook.Add Row.ContractLot, Row
If Row.TradeDate < pLTDate Then
pLTDate = Row.TradeDate
If IsNumeric(Row.FlatMV) And Row.FlatMV <> 0 Then pLTFlatPrice = Row.FlatMV
If IsNumeric(Row.BasisMV) Then pLTBasisPrice = Row.BasisMV
End If
End Sub
Public Property Get Row(ContractLot As String) As CRow:
Set Row = pHook.Item(ContractLot)
End Property
Public Property Let Name(HookName As String):
pName = HookName
End Property
Public Property Get Name() As String:
Name = pName
End Property
Public Property Get LTFlatPrice() As Double:
LTFlatPrice = pLTFlatPrice
End Property
Public Property Get LTBasisPrice() As Double:
LTBasisPrice = pLTBasisPrice
End Property
Public Property Get LTDate() As Double:
LTDate = pLTDate
End Property
and here is the peace of code where the error happens (Object doesn't support this property or method):
For i = 2 To UBound(path, 1)
tName = path(i, 1)
Next i
Set PC = SArray.PC(tName)
For Each hook In PC
For Each row In hook
With Sheets("COB")
.Cells(ii, 2) = row.PC
.Cells(ii, 3) = row.hook
.Cells(ii, 4) = row.Period
End With
ii = ii + 1
Next row
Next hook

You can iterate over either the keys or the items of a dictionary:
Sub Tester()
Dim d As New Scripting.Dictionary
Dim k
d.Add "one", 1
d.Add "two", 2
d.Add "three", 3
For Each k In d.Keys
Debug.Print k
Next
For Each k In d.Items
Debug.Print k
Next
End Sub
So, you can expose your dictionary as a property of an object and iterate over that. It does mean you need to specify .Items though (since it will default to keys.

Related

How To Code So That Intellisense Follows The Complete Chain

While this code works and I can assign and retrieve values across all levels, intellisense only displays the methods or properties 1 level deep. How would I go about coding this so that I can follow my "Path" all the way down using intellisense and not necessarily have to just remember the methods or properties?
for instance if I type Wip. I get
but when I type Wip.Parts("Test"). , the SequenceNumbers member and its Methods/Properties are not displayed
I have the following code
clsSeq:
Option Explicit
Private iSeq As String
Private iQty As Double
Public Property Get Qty() As Double
Qty = iQty
End Property
Public Property Let Qty(lQty As Double)
iQty = lQty
End Property
Public Property Get Sequence() As String
Sequence = iSeq
End Property
Public Property Let Sequence(lSeq As String)
iSeq = lSeq
End Property
clsPart:
Option Explicit
Private iPart As String
Public SequenceNumbers As Collection
Public Property Get PartNumber() As String
PartNumber = iPart
End Property
Public Property Let PartNumber(lPart As String)
iPart = lPart
End Property
Public Sub AddSequence(aSeq As String, aQty As Double)
Dim iSeq As clsSeq
If SeqExists(aSeq) Then
Set iSeq = SequenceNumbers.Item(aSeq)
iSeq.Qty = iSeq.Qty + aQty
Else
Set iSeq = New clsSeq
With iSeq
.Sequence = aSeq
.Qty = aQty
End With
SequenceNumbers.Add iSeq, iSeq.Sequence
End If
Set iSeq = Nothing
End Sub
Private Sub Class_Initialize()
Set SequenceNumbers = New Collection
End Sub
Private Function SeqExists(iSeq As String) As Boolean
Dim v As Variant
On Error Resume Next
v = IsObject(SequenceNumbers.Item(iSeq))
SeqExists = Not IsEmpty(v)
End Function
clsParts:
Option Explicit
Public Parts As Collection
Public Sub AddPart(iPart As String)
Dim iPrt As clsPart
If Not PartExists(iPart) Then
Set iPrt = New clsPart
With iPrt
.PartNumber = iPart
End With
Parts.Add iPrt, iPrt.PartNumber
End If
End Sub
Private Function PartExists(iPT As String) As Boolean
Dim v As Variant
On Error Resume Next
v = IsObject(Parts.Item(iPT))
PartExists = Not IsEmpty(v)
End Function
Private Sub Class_Initialize()
Set Parts = New Collection
End Sub
modTest:
Sub TestWipCls()
Dim Wip As clsParts
Dim Part As clsPart
Set Wip = New clsParts
Wip.AddPart ("Test")
Set Part = Wip.Parts("Test")
Part.AddSequence "Proc7", 1505
Debug.Print Wip.Parts("Test").SequenceNumbers("Proc7").Qty
Part.AddSequence "Proc7", 100
Debug.Print Wip.Parts("Test").SequenceNumbers("Proc7").Qty
End Sub
That is because Parts is a Collection and its Default Member Call (or .Item) will return a value/object depending what was stored. While editing your code VBA does not know what kind of value/object is stored in the collection (as this is only established during run-time, eg. late-bound), so it can not give you any Intellisense-suggestions.
To circumvent this, you need a method (property/function) that returns a defined type of value/object (early-bound).
btw. (myCollection.("Foo") is the same as myCollection.Item("Foo"))
The solution is to create a custom collection that returns a value of a defined type.
The following example also explains how to implement a custom Collection so you can use the default member call instead of using .Item.
How to use the Implements in Excel VBA
While we're at it, please never use public variables in classes, make them accessible via Property Let/Set/Get methods!
More on this here: https://rubberduckvba.wordpress.com/2019/07/08/about-class-modules/
Edit:
Example for a custom Collection for classes that implement ICustomElement (Interfaces are explained in the link above)
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CustomCollectionTemplate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'#Folder("Classes")
Option Explicit
Private Type TCustomCollection
CustomCollection as Collection
End Type
Dim this as TCustomCollection
Private Sub Class_Initialize()
Set this.CustomCollection = New Collection
End Sub
Private Sub Class_Terminate()
Set this.CustomCollection = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
Set NewEnum = this.CustomCollection.[_NewEnum]
End Property
Public Sub Add(ByVal newCustomElement As ICustomElement)
this.CustomCollection.Add newCustomElement
End Sub
Public Sub Remove(ByVal Index As Long)
this.CustomCollection.Remove Index
End Sub
Public Function Item(ByVal Index As Long) As ICustomElement
Set Item = this.CustomCollection.Item(Index)
End Function
Public Function Count() As Long
Count = this.CustomCollection.Count
End Function
Thanks to M.Doerner & Mathieu Guindeon for the edits/comments

Method to access class members by item numbers

Sorry for newbie question. I'm new to VBA class.
I created a cRanges class which is basically a collection of another custom object. And I defined a Item method for it. But I couldn't understand why the Item method of cRanges class didn't work?
Here's my code:
' CLASS MODULE - cRange
' Member variables
Private m_Low As String
Private m_High As String
' Properties
Property Get low() As String
low = m_Low
End Property
Property Get high() As String
high = m_High
End Property
Property Let low(s As String)
m_Low = s
End Property
Property Let high(s As String)
m_High = s
End Property
------------------
' CLASS MODULE - cRanges
' Member variables
Private m_Ranges As New Collection
Private r As New cRange
' Methods
Public Sub Add(r As cRange)
m_Ranges.Add r
End Sub
Public Sub Remove(r As cRange)
m_Ranges.Remove r
End Sub
Public Function Count() As Long
Count = m_Ranges.Count
End Function
Public Function Item(i As Integer) As cRange
If i > 0 And i <= m_Ranges.Count Then Set Items = m_Ranges.Item(i)
End Function
--------------------
Sub main()
Dim r As New cRange
Dim rr As New cRanges
r.low = "2"
r.high = "9"
rr.Add r
Debug.Print r.low
Debug.Print r.high
Debug.Print rr.Count
Debug.Print rr.Item(1).high '<-- Object variable or with block variable not set
End Sub
Thanks!
...................................................................................

VBA instance item not being changed

' CDays
Private pZone As New Collection
Public Property Get Zone() As Collection
Set Zone = pZone
End Property
Public Property Let Zone(Value As Variant)
For Each element In Value
pZone.Add element
Next
End Property
and sub has
' Main Sub
dy.Zone.item("Zone1")(5) = 0
Where dy is an instance
"Zone1" is set as the key for Item1 in below
Structure for dy instance looks as follows
This does not change the value in Item(5) however. Why?
Create class which will wrap the items which will be added to VBA.Collection. Then it is possible to add/change such items using the collection reference. HTH
Class Foo
Option Explicit
Private m_id As Integer
Private m_value As String
Public Property Get ID() As Variant
ID = m_id
End Property
Public Property Let ID(ByVal vNewValue As Variant)
m_id = vNewValue
End Property
Public Property Get Val() As Variant
Val = m_value
End Property
Public Property Let Val(ByVal vNewValue As Variant)
m_value = vNewValue
End Property
Module
Option Explicit
Sub test1()
Dim col As VBA.Collection
Set col = New VBA.Collection
Dim f As Foo
Set f = New Foo
f.ID = 1
f.Val = "AAA"
col.Add f, VBA.CStr(f.ID)
Debug.Print col(f.ID).Val
col(f.ID).Val = "BBB"
Debug.Print col(f.ID).Val
End Sub
Output
AAA
BBB

VBA Classes - How to have a class hold additional classes

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
Date
Time
Description
However each transaction can also have many business related contacts with the following properties
Business Contact Name
Business Area
Percentage of Bill
Are there any examples of how this would be done.
I have tried adding a second class for the business contact and then building a collection inside the transaction class, all with no joy.
I have also tried making the business contact details a collection within the transaction class also with no joy.
Below is what I have so far, but i may have gone down a blind alley and it may not be worth trying to rescue the code
Any help much appreciated.
Thanks
JP
Test sub - trying to write the data in and get it back out
Sub test()
Dim x As Integer
Dim xx As Integer
'code to populate some objects
Dim clocklist As Collection
Dim clock As classClocks
Dim businesscontactlist As Collection
Dim businesscontact As classBusinessContact
Set businesscontactlist = New Collection
Set clocklist = New Collection
For x = 1 To 3
Set clock = New classClocks
clock.LawyerName = "lawyer " & Str(x)
For xx = 1 To 3
businesscontact.Name = "Business Contact " & Str(xx)
businesscontactlist.Add businesscontact
Next xx
clock.BusinessContactAdd businesscontactlist '----- errors here
clocklist.Add clock
Next x
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
Clock Class - this is the transaction class
Private pLawyerName As String
Private pBusinessContactList As Collection
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(ByRef strName() As Collection)
Set pBusinessContactList = New Collection
Dim businesscontact As classBusinessContact
Set businesscontact = New classBusinessContact
For Each businesscontact In strName
businesscontact.Name = strName.Item()
pBusinessContactList.Add businesscontact
Next
End Property
Business contact Class - For the moment it only has one property
Private pBusinessContactName As String
Public Property Get Name() As String
Name = pBusinessContactName
End Property
Public Property Let Name(ByVal sName As String)
pBusinessContactName = sName
End Property
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
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).
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.

get an array into a class.property

I have a class with the following properties:
Dim pBonds() as string
Private Property Get Bonds() As String
Bonds = pBonds
End Property
Private Property Get Bond(index As Long) As String
Bond = pBonds(index)
End Property
Private Property Let Bond(index As Long, strValue As String)
If index > UBound(pBonds) Then ReDim Preserve pBonds(index)
pBond(index) = strValue
End Property
when I try:
Set o = New CBondBasket
For k = LBound(arr) To UBound(arr)
o.Bond(k) = arr(k)
Next k
I get error Method or data member not found
Any idea where that comes from?
made the changes
marked them as public now and added initialization and byval (got me another error w/o it)
Private Sub Class_Initialize()
ReDim pBonds(0)
End Sub
Public Property Get Bonds() As String()
Bonds = pBonds
End Property
Public Property Get Bond(index As Long) As String
Bond = pBonds(index)
End Property
Public Property Let Bond(ByVal index As Long, ByVal strValue As String)
If index > UBound(pBonds) Then ReDim Preserve pBonds(index)
pBonds(index) = strValue
End Property
error is: Definitions of property procedures for the same property are inconsistent or property procedure has an optional parameter, a ParamArray or an invalid set final parameter can anyone help me with that? thanks
You also need to initialise the pBonds array or you will get an error when calling UBound the first time:
Main module
Option Explicit
Sub testClass()
Dim o As CBondBasket
Dim k As Long
Dim arr As Variant
arr = Array(1, 2, 3, 4, 5)
Set o = New CBondBasket
For k = LBound(arr) To UBound(arr)
o.Bond(k) = arr(k)
Next k
For k = LBound(o.Bonds) To UBound(o.Bonds)
Debug.Print o.Bond(k)
Next k
End Sub
Class CBondBasket
Private pBonds() As String
Private Sub Class_Initialize()
ReDim pBonds(0)
End Sub
Public Property Get Bonds() As String()
Bonds = pBonds
End Property
Public Property Get Bond(index As Long) As String
Bond = pBonds(index)
End Property
Public Property Let Bond(index As Long, strValue As String)
If index > UBound(pBonds) Then ReDim Preserve pBonds(index)
pBonds(index) = strValue
End Property
Your class methods are marked Private if you want to expose them to automation clients make them Public.
(You also need parens to return an array: Public Property Get Bonds() As String())
Option Compare Database
Option Explicit
Public Function test1() As Integer
Dim sdate(2) As Date
Dim edate(2) As Date
Dim serdat As Class_erviceDate
sdate(1) = #1/2/2015#
edate(1) = #10/21/2015#
sdate(2) = #2/5/2015#
edate(2) = #12/25/2015#
Set serdat = New Class_ServiceDate
serdat.serviceStart = sdate
serdat.serviceEnd = edate
Debug.Print serdat.serviceStart(1), serdat.serviceEnd(1)
Debug.Print serdat.serviceStart(2), serdat.serviceEnd(2)
End Function
Option Compare Database
Option Explicit
Private f_datServiceStart As Variant
Private f_datServiceEnd As Variant
Public Property Get serviceStart() As Variant
serviceStart = f_datServiceStart
End Property
Public Property Let serviceStart(Value As Variant)
f_datServiceStart = Value
End Property
Public Property Get serviceEnd() As Variant
serviceEnd = f_datServiceEnd
End Property
Public Property Let serviceEnd(Value As Variant)
f_datServiceEnd = Value
End Property