I'm trying to write a function that would sort a collection of objects. Since the objects are all of the same type (the same user-defined class), their property set is the same. Is it possible to discover the object's properties (through code) so as to put the collection in a bi-dimensional array, each row being for an object, each column for one of its property?
Another solution would be to copy each object from the collection to an array of objects, and sort them by one of their property, whose name is passed to the function as a string. But I don't see how I can point to the object's property using the property's name passed as a string.
For a collection, it is best to sort it by it's Keys (that's what they're there for) -- but in case you don't have the keys list (lost your keys!):
'Give an input "Data As Collection"
Dim vItm As Variant
Dim i As Long, j As Long
Dim vTemp As Variant
For i = 1 To Data.Count – 1
For j = i + 1 To Data.Count
If CompareKeys(Data(i).myMemberKey, Data(j).myMemberKey) Then
'store the lesser item
vTemp = Data(j)
'remove the lesser item
Data.Remove j
're-add the lesser item before the greater Item
Data.Add vTemp, , i
End If
Next j
Next i
Come up with your own CompareKey function which will return true or false if the UDT member variables are >, < or 0 to one another. The reason you have to delete and re-add is because you cannot 'swap' internal members in a vb6/vba collection object.
Best of luck
EDIT:
To access a property you have the name of programmatically (as a string), use VB's CallByName function in the form:
Result = CallByName(MyObject, "MyProperty", vbGet)
Related
Creating a dictionary in VBA and I came across something that I found curious.
When I add an Outlook Calendar Item object to a dictionary it is ByRef, but when I add a dimmed Integer it is ByVal.
My two questions are:
Is it possible to add the dimmed Integer ByRef?
Why are these two items added differently (I know that one is an object and one is base type, looking for a little more detail)?
I looked at this: VB dictionary of Objects ByRef, but it only talks about the object case and not the integer case.
Here is the code showing what happens:
Sub checkbyref()
Dim gCal As Items
Dim dict As New Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim intCheck As Integer
intCheck = 5
Set gCal = GetFolderPath("\\GoogleSync\GoogleSyncCal").Items 'gets caledar items based on path
strMeetingStart = "01/5/2019 12:00 AM"
strGSearch = "[Start] >= '" & strMeetingStart & "'"
gCal.Sort "[Start]"
Set gCal = gCal.Restrict(strGSearch)
Debug.Print intCheck 'prints "5"
Debug.Print gCal(1).Start 'prints 1/7/2019 9:30:00 AM"
dict.Add "check", intCheck
dict.Add "cal", gCal(1)
'direction 1
dict("check") = 4
dict("cal").Start = "1/1/2020 9:00 AM"
Debug.Print intCheck 'prints "5"
Debug.Print gCal(1).Start 'prints "1/1/2020 9:00:00 AM"
'direction 2
intCheck = 6
gCal(1).Start = "1/1/2021 9:00 AM"
Debug.Print dict("check") 'prints "4"
Debug.Print dict("cal").Start 'prints "1/1/2021 9:00:00 AM"
End Sub
As you can see intCheck is not effected by changes in the dict but gCal(1) is.
tldr; No, you can't add an intrinsic type to a Scripting.Dictionary ByRef. VBA is not the same type of managed environment as .NET (which uses generational garbage collection instead of reference counting), so proper memory management would be impossible. Note that .NET Dictionary's don't work that way with intrinsic types either.
For the second part of your question, the thing to keep in mind is that Dictionary is a COM object - when you reference it in a project (or call CreateObject on one of its types), it starts up a COM server for scrrun.dll to provide Scripting objects to the caller. That means that when you make any call on one of its members, you're passing all of the arguments through the COM marshaller. The Add method is a member of the IDictionary interface, and has this interface description:
[id(0x00000001), helpstring("Add a new key and item to the dictionary."), helpcontext(0x00214b3c)]
HRESULT Add(
[in] VARIANT* Key,
[in] VARIANT* Item);
Note that both the Key and Item are pointers to a Variant. When you pass an Integer (or any other intrinsic type), the run-time is first performing a cast to a Variant, then passing the resulting Variant pointer to the Add method. At this point, the Dictionary is solely responsible for managing the memory of the copy. A VARIANT with an intrinsic type contains the value of the intrinsic in its data area - not a pointer to the underlying memory. This means that when the marshaller casts it, the only thing that ends up getting passed is the value. Contrast this to an Object. An Object wrapped in a Variant has the pointer to its IDispatch interface in the data area, and the marshaller has to increment the reference count when it wraps it.
The inherent issue in passing intrinsic types as pointers is that there is no way for the either side of the COM transaction to know who is responsible for freeing the memory when it goes out of scope. Consider this code:
Dim foo As Scripting.Dictionary 'Module level
Public Sub Bar()
Dim intrinsic As Integer
Set foo = New Scripting.Dictionary
foo.Add "key", intrinsic
End Sub
The problem is that intrinsic is allocated memory on the stack when you execute Bar, but foo isn't freed when the procedure exits - intrinsic is. If the run-time passed intrinsic as a reference, you would be left with a bad pointer stored in foo after that memory was deallocated. If you tried to use it later in another procedure, you would either get a trash value if the memory was re-used, or an access violation.
Now compare this to passing an Object:
Dim foo As Scripting.Dictionary 'Module level
Public Sub Bar()
Dim obj As SomeClass
Set foo = New Scripting.Dictionary
Set obj = New SomeClass
foo.Add "key", obj
End Sub
Objects in VBA are reference counted, and the reference count determines their life-span. The run-time will only release them when the reference count is zero. In this case, when you Set obj = New SomeClass, it increments the reference count to one. obj (the local variable) holds a pointer to that created object. When you call foo.Add "key", obj, the marshaller wraps the object in a Variant and increments the reference count again to account for its pointer to the object. When the procedure exits, obj loses scope and the reference count is decrement, leaving a count of 1. The run-time knows that something has a pointer to it, so it doesn't tear down the object because there is a possibility that it will be accessed later. It won't decrement the reference count again until foo is destroyed and the last reference to the object is decremented.
As to your first question, the only way to do something like this in VBA would be to provide your own object wrapper to "box" the value:
'BoxedInteger.cls
Option Explicit
Private boxed As Integer
Public Property Get Value() As Integer
Value = boxed
End Property
Public Property Let Value(rhs As Integer)
boxed = rhs
End Property
If you wanted to get fancy with it, you could make Value the default member. Then your code would look something more like this:
Dim dict As New Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim check As BoxedInteger
Set check = New BoxedInteger
check.Value = 5
dict.Add "check", check
Add method of dictionary just adds a key and item pair to a Dictionary object. In case of dict.Add "check", intCheck the item here is an integer value. which means there is no reference added, just the integer value. If you want to track the original variable back, you will need to wrapp it in a class as the user Comintern has suggested, or you will have to update both, the dictionary and the original integer variable, simultaneously. Example:
Sub checkbyref()
Dim dict As New Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim intCheck As Integer
intCheck = 5
Debug.Print intCheck 'prints "5"
dict.Add "check", intCheck
' dict("check") = 4
SetDictionaryWithInteger dict, "check", 4, intCheck
Debug.Print dict("check") & "|" & intCheck
' intCheck = 6
SetDictionaryWithInteger dict, "check", 6, intCheck
Debug.Print dict("check") & "|" & intCheck
End Sub
Private Sub SetDictionaryWithInteger( _
dic As Scripting.Dictionary, _
key As String, _
newVal As Integer, _
ByRef source As Integer)
dic(key) = newVal
source = newVal
End Sub
Note: ByRef is the default in Visual Basic, here it is used only to emphasize that the integer value of intCheck will be modified.
And to answer your questions:
1. no, integer is added like a value
2. they are not added differently, they are both added the same, which means its values is added. But in case of intCheck it is the value itself (e.g. 5) and nothing more, but in case of gCal the value is the address to the data structure, so it can be still reached through this address.
my Excel-applicatin has a module with utility functions. One of them adds items to arrays:
Public Sub addToArray(ByRef arr As Variant, item As Variant)
'Sub adds one element to a referenced array
On Error Resume Next
Dim bd As Long
bd = UBound(arr)
If Err.Number = 0 Then
ReDim Preserve arr(bd + 1)
Else
ReDim Preserve arr(0)
End If
arr(UBound(arr)) = item
End Sub
This Sub works perfectly as long as I pass arrays that are not referenced as object members.
addToArray arr, item
works but...
addToArray myObject.arr, item
doesn't...
the second call adds the item to an array but loses the reference to myObject
I can write a workaround by implementing a method in each class (doesn't need object references because it accesses properties of the same object) but that's not how I wanted to solve this problem.
Pls hälp ;)
Unfortunately, this is not possible due to limitations of VBA.
When you're accessing a public variant field of an object, it's get copied by value, so the original reference is not exposed. And if you declared an array (which is internally a reference type) as a public field, you would get the compile error "Constants, fixed-length strings, arrays, user-defined types and Declare statements not allowed as Public members of object modules"
TL;DR:
Is there any way to pass a class collection/list to a library sorting algorithm, and get it to return a sorted list (preferably by a named/default class property)?
I've recently been learning some Python, and was impressed by the Sorted() function, which can sort any iterable. For numbers this is straightforward, for classes however, it is possible to assign a comparison method like this. The method tells comparison operators how to compare 2 instances of the class. Amongst other things it allows you to use builtin sorting algorithms to sort a collection of the class.
In VBA I've been half successful in mimicking this. By setting a class' default member Attribute, you can use comparison operators (<,=,>=, etc.) on classes directly. Take the example class:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "defaultProp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private randVal As Single
Public Property Get DefaultValue() As Single
Attribute Value.VB_UserMemId = 0
DefaultValue = randVal
End Property
Private Property Let DefaultValue(ByVal value As Single)
randVal = value
End Property
Private Sub Class_Initialize()
DefaultValue = Rnd()
End Sub
Two instances of this class can be compared:
Dim instance1 As New defaultProp
Dim instance2 As New defaultProp
Debug.Print instance1.DefaultValue > instance2.DefaultValue
Debug.Print instance1 > instance2 'exactly equivalent, as the DefaultValue has the correct Attribute
And if I was implementing a VBA sort algorithm that can sort values, there should be no problem sorting classes by default value*. However I would prefer to use a builtin/library sorting algorithm (for the same reasons anyone would; clarity, efficiency, proper error handling etc.)
*One of these algorithms would work for that, although must be modified to switch the entire class round, not the value of it (by adding Sets)
Since VBA comparison operators have no issue, I assumed the same would be true for whatever the library was using. However when I tried with an ArrayList:
Sub testArrayList()
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
' Initialise the ArrayList, for instance by generating random values
Dim i As Long
Dim v As defaultProp
For i = 1 To 5
Set v = New defaultProp
arr.Add v 'no problem here
Next i
arr.Sort 'raises an error
End Sub
I get an error
Failed to compare two elements in the array
So what's going on? Is it a flaw in my approach - is the default attribute not making it to the ArrayList? Or maybe the comparison operator in whatever language the library is written in is not as floopy-gloopy as the ones VBA and Python use? Any suggestions on more builtin sorting algorithms to try would be useful too!
It's not about the VBA comparison operators, ArrayList is a .NET class, so you're in the .NET world when you use it.
arr.Add v 'no problem here
You're adding instances of the defaultProp class; it doesn't matter that you have a default property on the type, .NET doesn't care about default properties. If you want to sort DefaultValue values, then do arr.Add v.DefaultValue or arr.Add (v) - then your ArrayList will contain items of type Single, which it knows how to sort.
In order for ArrayList.Sort to work with instances of your custom class, its items need to implement the IComparable interface, which is the case for System.Int32 (i.e. Long in VBA), System.String and every other primitive .NET types, and I think the VBA primitive types would indeed marshal correctly through .NET interop - but not custom classes.
Try adding a reference to mscorlib.tlb, and then in the defaultProp class module, specify this (you can't implement an interface that's defined in a late-bound library):
Implements IComparable
Then implement the interface - should look something like this (use the codepane dropdowns to make sure to get the correct signature - don't just copy-paste this snippet:
Private Function IComparable_CompareTo(ByVal obj As Variant) As Long
Dim other As defaultProp
Set other = obj
' return Less than zero (-1) if this object
' is less than the object specified by the CompareTo method.
' return Zero (0) if this object is equal to the object
' specified by the CompareTo method.
' return Greater than zero (1) if this object is greater than
' the object specified by the CompareTo method.
End Function
Now that your custom class implements the interface ArrayList.Sort uses to determine how your defaultProp items relate to each other, I don't see a reason for it to fail.
IMO, you are abusing things by mixing things cross the boundaries. You're using VBA's default properties (something I generally perceive as a bad practice), then you're using .NET's ArrayList and trying to Sort it.
I think it would be much more logical to see if you can implement IComparable on the VBA class and then let the ArrayList use the IComparable interface to compare an object against other by however you want it to compare, without using any default properties hacked.
If you add the DefaultValue to the arr it would work:
Sub testArrayList()
'... code
For i = 1 To 5
Set v = New defaultProp
arr.Add v.DefaultValue
Next i
arr.Sort
End Sub
Obviously the implementation of .Sort of ArrayList is a bit strange and does not like comparing objects and their default values (could not find the implementation of the Sort() method). Although, this would work flawlessly:
For i = 1 To 5
Set v = New defaultProp
arr.Add v
Next i
Debug.Print arr(1) > arr(2)
This is a possible implementation of sorting, that would work for the arr object as expected. However, it is not part of the ArrayList library:
Public Function varBubbleSort(varTempArray As Object) As Object
Dim varTemp As Object
Dim lngCounter As Long
Dim blnNoExchanges As Boolean
Do
blnNoExchanges = True
For lngCounter = 0 To varTempArray.Count - 2
If varTempArray(lngCounter) > varTempArray(lngCounter + 1) Then
blnNoExchanges = False
Set varTemp = varTempArray(lngCounter)
varTempArray(lngCounter) = varTempArray(lngCounter + 1)
varTempArray(lngCounter + 1) = varTemp
End If
Next lngCounter
Loop While Not (blnNoExchanges)
Set varBubbleSort = varTempArray
On Error GoTo 0
Exit Function
End Function
But the sorting is ok:
I would like to take any number of objects via a ParamArray and then add them, or variables nested within them to a collection. The tricky part is that if that nested object is a container of some sort (collection, scripting dictionary or even a custom class with a count method) also has variables nested within it, I want it to return those in the collection, NOT the container.
It would go something like this, let's start by creating a use case:
Sub MakeItems()
Dim ReturnedColl as Collection
Dim aString as String
Dim TopColl as New Collection, NestedColl as New Collection, SubNestedDic as New Dictionary
Dim aRangeofManyCells as Range, aRangeofOneCell as Range
Dim anObject as newObject, NestedObject as New Object, SubNestedObject as New Object
aString = "Just a string"
Set aRangeofManyCells = Range("A1:C3")
Set aRangeofOneCell = Range("A4")
SubNestedDic.Add SubNestedObject
SubNestedDic.Add aRangeofOneCell
NestedColl.Add SubNestedDic
NestedColl.Add NestedObject
NestedColl.Add SubNestedDic
NestedColl.Add aRangeofManyCells
TopColl.Add aString
TopColl.AddNestedColl
Set ReturnedColl = UnNest(TopColl, TopColl, anObject, Range("Sheet1:Sheet3!Q1"))
For each Item in ReturnedColl
'do something
Next Item
End Sub
Here comes the part I can't figure out.
I would want to do a loop like this making the Item the new Items, and then look into each Item within item (if it has any), but without losing track of the original Items, because I'll have to go to the next Item.
Function UnNest(ParamArray Items() as Variant) as Collection
For Each Item in Items
If Item 'is a container of some sort' Then
'some kind of loop through all nests, subnests, subsubnests,...
Else
UnNest.Add Item
Endif
Next Item
End Function
So the end result should be a collection that holds:
"Just a String" from aString
9 range objects corresponding to the cells Range("A1:C3") from aRangeofManyCells
1 range object corresponding to Range("A4"), from aRangeofOneCell
The objects anObject, NestedObject, and SubNestedObject
All of the above 2x, because I put TopColl as an argument to the Function 2x
And also,
an additional anObject, because I added that as an argument to the function
3 Range objects, corresponding to Sheet1Q1, Sheet2Q2, Sheet3Q3
I know that's a tall order, but there has got to be some way to do that loop.
Thanks for any help!
This routine would appear to solve one of your use cases. Certainly it worked for me although I was not passing anything other than regular variables and arrays.
One problem I could not overcome was that I could not determine the type of an Object. Unless you can solve that problem, I do not see how to achieve your entire objective.
Sub DeNestParamArray(RetnValue() As Variant, ParamArray Nested() As Variant)
' Coded Nov 2010
' Each time a ParamArray is passed to a sub-routine, it is nested in a one
' element Variant array. This routine finds the bottom level of the nesting and
' sets RetnValue to the values in the original parameter array so that other routine
' need not be concerned with this complication.
Dim NestedCrnt As Variant
Dim Inx As Integer
NestedCrnt = Nested
' Find bottom level of nesting
Do While True
If VarType(NestedCrnt) < vbArray Then
' Have found a non-array element so must have reached the bottom level
Debug.Assert False ' Should have exited loop at previous level
Exit Do
End If
If NumDim(NestedCrnt) = 1 Then
If LBound(NestedCrnt) = UBound(NestedCrnt) Then
' This is a one element array
If VarType(NestedCrnt(LBound(NestedCrnt))) < vbArray Then
' But it does not contain an array so the user only specified
' one value; a literal or a non-array variable
' This is a valid exit from this loop
Exit Do
End If
NestedCrnt = NestedCrnt(LBound(NestedCrnt))
Else
' This is a one-dimensional, non-nested array
' This is the usual exit from this loop
Exit Do
End If
Else
Debug.Assert False ' This is an array but not a one-dimensional array
Exit Do
End If
Loop
' Have found bottom level array. Save contents in Return array.
ReDim RetnValue(LBound(NestedCrnt) To UBound(NestedCrnt))
For Inx = LBound(NestedCrnt) To UBound(NestedCrnt)
If VarType(NestedCrnt(Inx)) = vbObject Then
Set RetnValue(Inx) = NestedCrnt(Inx)
Else
RetnValue(Inx) = NestedCrnt(Inx)
End If
Next
End Sub
Public Function NumDim(ParamArray TestArray() As Variant) As Integer
' Returns the number of dimensions of TestArray.
' If there is an official way of determining the number of dimensions, I cannot find it.
' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
' By trapping that failure it can determine the last test that did not fail.
' Coded June 2010. Documentation added July 2010.
' * TestArray() is a ParamArray because it allows the passing of arrays of any type.
' * The array to be tested in not TestArray but TestArray(LBound(TestArray)).
' * The routine does not validate that TestArray(LBound(TestArray)) is an array. If
' it is not an array, the routine return 0.
' * The routine does not check for more than one parameter. If the call was
' NumDim(MyArray1, MyArray2), it would ignore MyArray2.
Dim TestDim As Integer
Dim TestResult As Integer
On Error GoTo Finish
TestDim = 1
Do While True
TestResult = LBound(TestArray(LBound(TestArray)), TestDim)
TestDim = TestDim + 1
Loop
Finish:
NumDim = TestDim - 1
End Function
I have a parent class: CMove
I have a bunch of child classes that inherit CMove: M[Name of Move]
I have a dictionary: pMoveSet(of Stings, CMove)
The Values of the dictionary are New child classes: e.g. pMoveSet(Key1, New MTackle)
I want to set the instance from the dictionary to an array (as CMove) that holds instances of the child classes: PossMoves(i) = kvp.Value
I do this in a “For Each” loop over the dictionary where I check the keys to see if I want the value. If I want the value, I set the value of the kvp equal to an element of the array.
I have a msgbox that properly displays the array position and the name of the child object directly after the child object is added to the array.
My code leaves the loop and I imagine the array should carry all the relevant child classes of CMove that I want.
A msgbox identical to the one in the “For Each” loop crashes with the error “NullReferenceException was unhandled. Object reference not set to an instance of an object.”
It seems the instance that is created and applied to the array originally in the “For Each” loop is lost by the time the array is called again outside the loop.
How can I fix this? I would appreciate some clarity on how to handle this. The code is below.
Dim PossMoves() As CMove, kvp As KeyValuePair(Of String, CMove)
ReDim PossMoves(0)
For Each kvp In pMoveSet
If Val(kvp.Key) < pLvl Then
PossMoves(UBound(PossMoves)) = kvp.Value
MsgBox(UBound(PossMoves) & vbCrLf & PossMoves(UBound(PossMoves)).Name)
ReDim PossMoves(UBound(PossMoves) + 1) 'Will add unused element after the last possible move
End If
Next
ReDim Preserve PossMoves(UBound(PossMoves) - 1) 'Removes blank value at the top of array
MsgBox(UBound(PossMoves) & vbCrLf & PossMoves(UBound(PossMoves)).Name) 'Error on this line.
The problem is that you are not preserving the array when you resize it. Therefore, every time you resize it to add a new element to the array, it clears the array. To fix it, simply change:
ReDim PossMoves(UBound(PossMoves) + 1)
To:
ReDim Preserve PossMoves(UBound(PossMoves) + 1)
However, I would strongly recommend that you use a List(Of CMove) instead of an array. It will be easier to work with and more efficient as well:
Dim PossMoves As New List(Of CMove)()
For Each kvp As KeyValuePair(Of String, CMove) In pMoveSet
If Integer.Parse(kvp.Key) < pLvl Then
PossMoves.Add(kvp.Value)
End If
Next