Extend Collections Class VBA - 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.

Related

How to put an array into a collection in VBA?

This is my first foray into VBA.
How can I put an array into a collection? I am making a collection with keys which contains reference data. It gets made once, and then used throughout my program. Everything I've found is either reading data in from a sheet in Excel, taking user input, or just putting in a couple of previously defined arrays; I want to do the initialisation of the arrays in the add call to the collection, as they aren't going to be used anywhere else.
I want to do something along the lines of
Dim c As Collection
Set c = New Collection
c.Add((1,"B"), "B")
c.Add((1.014,"FeC"), "Fe")
... 'about 100 lines
I can then retrieve the data by key, rather then having a hard to maintain If/ElseIf.
In Python, I would do
c = {"B": (1,"B"), "Fe": (1.014,"FeC"), ...}
A strange day. Two questions where I can use the same answer (see Convert 2 collections to a dictionary).
The basic advice I would give is to use a Scripting.Dictionary if only for the reason that you can get arrays back out using the Keys and Items Methods.
Here is the answer reproduced from the reference above
Inserting two collections (or any combination of an array or collection) into a dictionary is essentially boilerplate code. The best way to deal with boilerplate code is to put it in the object so that scripting dictionary would end up with a Method called 'AddPairs'.
In VBA you can't do this directly. Instead, you have to use a Wrapper, which is a term used for putting an object inside another object and using pass through methods to use the inner object. The class below 'wDictionary', shows how to Wrap the Scripting.Dictionary object to add the functionality you desire, plus an additional method which does what you want in reverse.
The AddPairs Method allows collections or Arrays to be used for the Keys and Items so, assuming you are now using wCollection you can write
pairs.AddPairs rembs, cols
The wDictionary also has a 'Pairs' method. The pairs method returns an array in the same way as the 'Items' and 'Keys' methods, but, each Item is an array of three Items, the Index, Key and Item. If you've been programming for a while, you'll understand the utility of the Pairs method.
Save the code below as a .cls file and then import it into your project. Replace references to Scripting.Dictionary with wDictionary (or New wDictionary if you are using CreateObject)
The code below is provided as an example. I haven't run any tests but I have done Rubberduck code inspections to ensure that there are no obvious errors.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "wDictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Type State
Host As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.Host = New Scripting.Dictionary
End Sub
Public Sub Add(ByRef Key As Variant, ByRef Item As Variant)
s.Host.Add Key, Item
End Sub
' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
Dim myItemsIndex As Long
Dim myLastItemsIndex As Long
If TypeName(Items) = "Collection" Then
myItemsIndex = 1
myLastItemsIndex = Items.Count
Else
myItemsIndex = LBound(Items)
myLastItemsIndex = UBound(Items)
End If
Dim myKey As Variant
For Each myKey In Keys
If myItemsIndex > myLastItemsIndex Then
Exit For
Else
s.Host.Add myKey, Items(myItemsIndex)
myItemsIndex = myItemsIndex + 1
End If
Next
End Sub
Public Property Get CompareMode() As VbCompareMethod
CompareMode = s.Host.CompareMode
End Property
Public Property Let CompareMode(ByVal RHS As VbCompareMethod)
s.Host.CompareMode = RHS
End Property
Public Property Get Count() As Long
Count = s.Host.Count
End Property
Public Function Exists(ByRef Key As Variant) As Boolean
Exists = s.Host.Exists(Key)
End Function
'#DefaultMember
Public Property Get Item(ByRef Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
If VBA.IsObject(s.Host(Key)) Then
Set Item = s.Host(Key)
Else
Item = s.Host(Key)
End If
End Property
Public Property Let Item(ByRef Key As Variant, ByVal RHS As Variant)
s.Host(Key) = RHS
End Property
Public Property Set Item(ByRef Key As Variant, ByVal RHS As Variant)
Set s.Host(Key) = RHS
End Property
Public Function Items() As Variant
Items = s.Host.Items
End Function
Public Function Keys() As Variant
Keys = s.Host.Keys
End Function
' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
Public Function Pairs() As Variant
Dim myPairs As Variant
ReDim myPairs(0 To s.Host.Count - 1)
Dim myIndex As Long
myIndex = 0
Dim myKey As Variant
For Each myKey In s.Host
myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
myIndex = myIndex + 1
Next
Pairs = myPairs
End Function
Public Property Let Key(ByRef Key As Variant, ByVal NewKey As Variant)
s.Host.Key(Key) = NewKey
End Property
Public Sub Remove(ByRef Key As Variant)
s.Host.Remove Key
End Sub
Public Sub RemoveAll()
s.Host.RemoveAll
End Sub
Update
Of course, the above is quite tedious to write, even though you any have to do the base wrapping once. This is where twinBasic (the up and coming replacement for VB/VBA) has a definite edge. In twin basic the whole code presented above can be condensed to
Class wDictionary
Implements Scripting.dictionary Via Host = New scripting.dictionary
' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
Public Function Pairs() As Variant
Dim myPairs As Variant
ReDim myPairs(0 To s.Host.Count - 1)
Dim myIndex As Long = 0
Dim myKey As Variant
For Each myKey In Host
myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
myIndex += 1
Next
Return myPairs
End Function
' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
Dim myItemsIndex As Long
Dim myLastItemsIndex As Long
If TypeName(Items) = "Collection" Then
myItemsIndex = 1
myLastItemsIndex = Items.Count
Else
myItemsIndex = LBound(Items)
myLastItemsIndex = UBound(Items)
End If
Dim myKey As Variant
For Each myKey In Keys
If myItemsIndex > myLastItemsIndex Then
Exit For
Else
Host.Add myKey, Items(myItemsIndex)
myItemsIndex += 1
End If
Next
End Sub
End Class
What's more, twinBasic makes it absolutely trivial to convert wCollection to an activeX.dll so that you can just add a reference to wCOllection just as you do for Scripting.DIctionary etc.

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.

3 Dimentional Dictionary

I'm trying make to a 3 Dimension Dictionary to store the data in the form of tools(material)(part)(attribute), and I have managed to create the Dictionary like this:
Dim Tools As New Dictionary(Of String, Dictionary(Of String, Dictionary(Of String, Decimal)))
And what I basically want to do is have some subs that manage that for me instead of dealing with that mess, and I want it to be like this like this:
Add_Attribute("Iron", "Pickaxe Head", "Durability", 204)
Get_Attribute("Stone", "Pickaxe Head", "Mining Speed")
Any answers would be greatly be appreciated.
My comment was not worded properly.
Create a class with add/get attributes function that accepts 3 parameters.
Concatenate the parameters and use it as dictionary key.
Option Explicit
Dim oDict As Dictionary
Public Function Add_Attribute(psParam1 As String, psParam2 As String, psParam3 As String, psValue As String)
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
oDict.Item(sKey) = psValue
Else
oDict.Add sKey, psValue
End If
End Function
Public Function Get_Attribute(psParam1 As String, psParam2 As String, psParam3 As String) As String
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
Get_Attribute = oDict.Item(sKey)
Else
Get_Attribute = ""
End If
End Function
Private Sub Class_Initialize()
Set oDict = New Dictionary
End Sub
Private Function BuildKey(psParam1 As String, psParam2 As String, psParam3 As String) As String
BuildKey = Join(Array(psParam1, psParam2, psParam3), "#")
End Function
Private Sub Class_Terminate()
Set oDict = Nothing
End Sub
Jules' answer of a custom class and concatenation of the three strings as a key will work very nicely for you and is a neat solution to your problem.
I'm posting another answer here for anyone who wants more of a dot notation style of solution. So one of the lines in your example could look something like:
mTools("Pickaxe Head").Attr("Durability").Material("Iron") = 204
I'm guessing you're deriving the values from a comboxbox or something similar, so working with strings might serve you fine. However, if you wished, you could go one stage further and create objects for the Attributes and Material parameters to achieve true dot notation (I didn't do the Parts parameter but you could do that one too):
mTools("Pickaxe Head").Durability.OnIron = 204
From a development point of view, the time consuming part would be to create all the parameter objects and keys, but if you are intending to manipulate the data anything more than trivially, it could make your life easier further down the track.
For your own project, are you certain that the data is genuinely 3 dimensional? Perhaps it's just the variable names that you've picked, but it seems as though you have one main object, ie the part (Pickaxe Head) which has some attributes (Durability and Mining Speed) which themselves have values based on the material they're operating on (Stone and Iron). Structurally, could it look like this?:
In terms of the code for this solution, create three classes. I've called them clsKeys, clsMaterials and clsPart.
For your clsKeys, the code is simply your field names:
Public Durability As String
Public MiningSpeed As String
Public Iron As String
Public Stone As String
For clsPart, the code contains the object names and a means of accessing them by string:
Public Name As String
Public Durability As New clsMaterials
Public MiningSpeed As New clsMaterials
Private mProperties As New Collection
Public Property Get Attr(field As String) As clsMaterials
Set Attr = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add Durability, .Durability
mProperties.Add MiningSpeed, .MiningSpeed
End With
End Sub
clsMaterials is similar:
Public OnStone As Integer
Public OnIron As Integer
Private mProperties As New Collection
Public Property Let Material(field As String, value As Variant)
mProperties.Remove field
mProperties.Add value, field
End Property
Public Property Get Material(field As String) As Variant
Material = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add OnStone, .Stone
mProperties.Add OnIron, .Iron
End With
End Sub
These classes can take as many objects as you like. You'll note I've instantiated the objects in the declaration which isn't best form but I've done it in the interest of space.
Finally, in a Module you need 3 routines: one to create the field keys, one to populate the data and one to retrieve it.
For the keys:
Option Explicit
Public Keys As clsKeys
Private mTools As Collection
Sub CreateKeys()
Set Keys = New clsKeys
With Keys
.Durability = "Durability"
.MiningSpeed = "Mining Speed"
.Iron = "Iron"
.Stone = "Stone"
End With
End Sub
For data population:
Sub PopulateData()
Dim oPart As clsPart
Set mTools = New Collection
Set oPart = New clsPart
With oPart
.Name = "Pickaxe Head"
'You could use dot notation
.Durability.OnIron = 204
.Durability.OnStone = 100
'Or plain strings
.Attr("Mining Speed").Material("Stone") = 50
.Attr("Mining Speed").Material("Iron") = 200
mTools.Add oPart, .Name
End With
End Sub
and for data retrieval:
Sub RetrieveValue()
Dim oPart As clsPart
Dim v As Variant
Set oPart = mTools("Pickaxe Head")
With oPart
'Using dot notation
v = oPart.Durability.OnIron
Debug.Print v
'Using plain strings
v = oPart.Attr("Durability").Material("Stone")
Debug.Print v
End With
'Or even without assigning the oPart variable
v = mTools("Pickaxe Head").Attr("Mining Speed").Material("Iron")
Debug.Print v
End Sub

VBA Object module must Implement ~?

I have created two classes, one being an interface for the other. Each time I try to instantiate Transition_Model I get:
Compile error: Object Module needs to implement '~' for interface'~'
To my understanding Implementing class is supposed to have a copy of all public subs, function, & properties. So I don't understant what is the problem here?
Have seen similar questions come up but either they refer to actual Sub or they include other complications making answer too complicated for me to understand.
Also note I tried changing Subs of Transition_Model to Private and add 'IModel_' in front of sub names(Just like top answer in second question I linked) but I still receive the same error.
IModel
Option Explicit
Public Enum Model_Types
Transition
Dummy
End Enum
Property Get M_Type() As Model_Types
End Property
Sub Run(Collat As Collateral)
End Sub
Sub Set_Params(key As String, value As Variant)
End Sub
Transition_Model
Option Explicit
Implements IModel
Private Transitions As Collection
Private Loan_States As Integer
Private Sub Class_Initialize()
Set Transitions = New Collection
End Sub
Public Property Get M_Type() As Model_Types
M_Type = Transition
End Property
Public Sub Run(Collat As Collateral)
Dim A_Transition As Transition
Dim New_Balance() As Double
Dim Row As Integer
For Row = 1 To UBound(Collat.Curr_Balance)
For Each A_Transition In Transitions
If A_Transition.Begining = i Then
New_Balance = New_Balance + Collat.Curr_Balance(Row) * A_Transition.Probability
End If
Next A_Transition
Next
End Sub
Public Sub Set_Params(key As String, value As Double)
Dim Split_key(1 To 2) As String
Dim New_Transition As Transition
Split_key = Split(key, "->")
Set New_Transition = New Transition
With New_Transition
.Begining = Split_key(1)
.Ending = Split_key(2)
.Probability = value
End With
Transitions.Add New_Transition, key
End Sub
Lastly the Sub I am using to test my class
Sub Transition_Model()
Dim Tested_Class As New Transition_Model
Dim Collat As New Collateral
'Test is the model type is correct
Debug.Assert Tested_Class.M_Type = Transition
'Test if Model without transition indeed does not affect balances of its collateral
Collat.Curr_Balance(1) = 0.5
Collat.Curr_Balance(2) = 0.5
Tested_Class.Run (Collat)
Debug.Assert ( _
Collat.Curr_Balance(1) = 0.5 And _
Collat.Curr_Balance(2) = 0.5)
End Sub
Actaully Per the second question I linked has the correct answer which I missed.
All subs need to start with 'IModel_' and rest ot the name has to match the name in IModel.
AND
This is the part i missed, you cannot use underscore in the Sub name.

VBA - Calling a function which accepts parent object as variable

Is it possible to create a function which accepts it's parent object as a variable? I suppose the simplest way to illustrate what I'm talking about is to provide an example:
Module 1 Code:
Function IsProduct() as Boolean
IsProduct = (vartype(Parent.Value) <> vbEmpty)
End Function
' "Parent" in this case would be a Range '
Module 2 Code:
Dim myRng as Range
If myRng.IsProduct Then Debug.Print "'Tis a product, sir."
I did not fully understand your question; as far as I know you cannot extend existing classes with methods in VBA. Maybe you want something like this?
Module 1:
Function IsProduct(parent As Object) as Boolean
IsProduct = (vartype(parent.Value) <> vbEmpty)
End Function
' This can take a Range as well as other objects as a parameter
Module 2:
Dim myRng as Range
If IsProduct(myRng) Then Debug.Print "'Tis a product, sir."
You would use the Me keyword inside a class to refer to the class. Like
IsProduct = IsEmpty(Me.Value)
You can simulate extending native classes in VBA. Create a class called cRange and give it two properties: Range and IsProduct
Private mclsRange As Range
Private Sub Class_Terminate()
Set mclsRange = Nothing
End Sub
Public Property Get Range() As Range
Set Range = mclsRange
End Property
Public Property Set Range(clsRange As Range)
Set mclsRange = clsRange
End Property
Public Property Get IsProduct() As Boolean
IsProduct = IsEmpty(Me.Range.Value)
End Property
Now you can use the Range property to get to all the built in properties and methods of the native Range object, and create any other properties (like IsProduct) that you want.