I have a collection of classes. I don't seem to be able to access the properties of my class though. Is this something I can do?
Here is my class clsProj:
Option Explicit
Private pValue As String
Public Property Get Value() As String
Value = pValue
End Property
Public Property Let Value(tempv As String)
pValue = tempv
End Property
And my sub:
Sub testtt()
Set cp = New Collection
cp.Add clsProj, "AAA"
cp.Add clsProj, "BBB"
cp("AAA").Value = "OK"
MsgBox (cp("AAA").Value)
End Sub
In sum I have a collection of classes clsProj that I index with strings(this is just a test sub) and I want to access properties of the clsProj for a given collection item ex:AAA in this case. What part is wrong here? I just can't seem to get it.
Classes are a bit tricky to understand but when you do they are really useful. Maybe this will help a bit:
Sub testtt()
Dim cp As Collection
Set cp = New Collection
Dim blabla As clsProj
Set blabla = New clsProj
Dim blabli As clsProj
Set blabli = New clsProj
blabla.Value = "OK"
blabli.Value = "KO"
cp.Add blabla, "AAA"
cp.Add blabli, "BBB"
MsgBox (cp("AAA").Value)
MsgBox (cp("BBB").Value)
Set blabla = Nothing
Set blabli = Nothing
End Sub
EDIT: mixing Collection, Class and For...Next loop:
Sub testtt()
Dim cp As Collection
Set cp = New Collection
Dim blabla As clsProj
Dim i As Integer
For i = 1 To 10
Set blabla = New clsProj
'"OK" value + a special character from ASCII table
blabla.Value = "OK " & Chr(32 + i)
cp.Add blabla, CStr("AAA" & i)
Set blabla = Nothing
Next i
'Test calling collection by key
MsgBox cp("AAA5").Value
'Test calling collection by item number and print it in
'"Immediate" window (ctrl+g to show that window from VBA editor)
For i = 1 To cp.Count
Debug.Print cp(i).Value
Next i
End Sub
Related
I create a collection of custom class objects, I am able to retrieve all the object property except for amount property (which is an array)
the following is my code
Sub Ledger()
Dim ActPeriod As Long
Dim ForcastPeriod As Long
Dim sth As Worksheet
Dim Account As New ClsAccount
Dim allaccounts As New Collection
ActPeriod = 3
ForecastPeriod = 3
For i = 1 To Sheet1.Range("A4:A26").count
If Sheet1.Cells(i, 1) <> 0 Then
counter = counter + 1
Set Account = New ClsAccount
With Account
.Code = Sheet1.Cells(i, 1)
.Name = Sheet1.Cells(i, 2)
.amount = Sheet1.Range(Cells(i, 3), Cells(i, 2 + ActPeriod))
allaccounts.add Account, .Code
End With
End If
Next i
MsgBox allaccounts(3).amount(1, 1)
End Sub
the code I used to create the class is as follow
Private AccAmount As Variant
Private AccGrowth As Variant
Private AccName As String
Private AccCode As String
Property Let amount(amt As Variant)
AccAmount = amt
End Property
Property Get amount() As Variant
amount = AccAmount
End Property
Property Let Name(n As String)
AccName = n
End Property
Property Get Name() As String
Name = AccName
End Property
Property Let Code(c As String)
AccCode = c
End Property
Property Get Code() As String
Code = AccCode
End Property
I am getting this error
MsgBox allaccounts(3).amount()(1, 1)
Without the parentheses VBA thinks you're trying to pass 1, 1 to the Property Get procedure, and that's not defined with any parameters...
I am using this code to hide a label based on if it contains % sign only and nothing else.
It is this part of the code it is erroring now when running. Error: "OLEFormat.Object: Invalid Request. Command cannot be applied to a shape range with multiple shapes"
What should be the correct code?
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
Sub c_Three_RemovePercent()
For slideNumber = 1 To 11
Set mydocument = ActivePresentation.Slides(slideNumber)
mydocument.Select
Dim myArray() As Variant
Dim myRange As Object
myArray = Array("Lbl_V1", "Lbl_V2", "Lbl_V3", "Lbl_V4", "Lbl_V5")
Set myRange = ActivePresentation.Slides(1).Shapes.Range(myArray)
With mydocument.Shapes.Range(myArray)
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
mydocument.Shapes(myRange).Visible = False
Else: mydocument.Shapes(myRange).Visible = True
End If
End With
Next slideNumber
End Sub
All these blindfolded late-bound member calls are easily confusing: you don't get IntelliSense to help you navigate the available members.
You're looking for an OLEObject, so declare one; assign it:
Dim oleLabel As Excel.OLEObject
Set oleLabel = ActivePresentation.Slides(1).Shapes("SomeShapeName").OLEFormat.Object
Now you want the control that's in that OLEObject's Object property, and you want to cast that control to its MSForms.Label interface:
Dim labelControl As MSForms.Label
Set labelControl = oleLabel.Object
Now you have an early-bound MSForms.Label interface to query, and IntelliSense guides you all the way:
If Contains(labelControl.Caption, "%") Then
'...
Else
'...
End If
Where Contains could look something like this:
Public Function Contains(ByVal source As String, ByVal substring As String) As Boolean
Contains = InStr(1, source, substring, vbTextCompare) > 0
End Function
You have an array of label control names you want to iterate - just iterate it:
Dim labelNames As Variant
labelNames = Array("label1", "label2", "label3", ...)
Dim i As Long
For i = LBound(labelNames) To UBound(labelNames)
Set oleLabel = currentSlide.Shapes(labelNames(i)).OLEObject
oleLabel.Visible = Not Contains(labelControl.Caption, "%")
Next
Note how this:
If BooleanExpression Then
Thing = True
Else
Thing = False
End If
Can be rewritten as:
Thing = BooleanExpression
For checking if string contains the vba function INSTR is typically best. Basically in the below example... Starting in the first position, check this text, look for "%", case insensative.
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
mydocument.Shapes(myRange).Visible = False
Else: mydocument.Shapes(myRange).Visible = True
End If
I have a sub that creates a Collection and adds Collections inside it. But I get an Wrong number of arguments or invalid property assignment error when adding a first collection in the loop:
Sub testState()
Dim stateCopy As State
Set stateCopy = New State
stateCopy.setStateName="some name"
stateCopy.storeBudgetWorkbooks
stateCopy.storeBudgetDatas 'error on this line
End Sub
Sub storeBudgetDatas() 'inside a class named State
...
Dim year As Integer
Dim i As Integer
i = 1
For year = 2014 To 2017
Set budgetWorkbook =
ExcelApp.Application.Workbooks.Open(budgetWorkbooks(i))
MsgBox ("still here") 'this message appears
allBudgetItems.Add getBudgetData(budgetWorkbook, year) 'this line is likely to cause problems
MsgBox ("and here") 'this message doesn't appear
budgetWorkbook.Close
i = i + 1
Next
End Sub
Function getBudgetData(budgetWorkbook As Workbook, year As Integer)
...
Dim budgetItems As Collection
Set budgetItems = getBudgetItems(year)
... 'setting attributes
getBudgetData = budgetItems(year)
End Function
Function getBudgetItems(year As Integer)
...
Dim resultCollection As Collection
Set resultCollection = New Collection
Dim itemCopy As Item
Dim i As Integer
For i = LBound(budgetItemNames) To UBound(budgetItemNames)
Set itemCopy = New Item
... 'setting attributes
resultCollection.Add itemCopy
Next
Set getBudgetItems = resultCollection
End Function
I'm not sure what's wrong here. getBudgetItems returns a collection. getBudgetData returns a collection as well. I tried adding/removing parenthesis but to no avail.
Figured it out. There should have been Set getBudgetData = budgetItems(year) instead of getBudgetData = budgetItems(year).
Since you haven't shown us all the relevant parts of your code, the best I can do is guess you're missing a Set:
Function getBudgetData(budgetWorkbook As Workbook, year As Integer)
...
Dim budgetItems As Collection
Set budgetItems = getBudgetItems(year)
... 'setting attributes
Set getBudgetData = budgetItems(year) ' Need Set here
End Function
I got an issue with "casting" variants to defined objects.
At runtime my variant variable is of type "Variant/Object/Listbox", which i then want to set to a ListBox variable to route it as a parameter to another function (GetSelected) that requires a Listbox object.
But I get the error 13: types incompatible on command "Set lst = v".
Any ideas how to get it working?
Code:
Function GetEditableControlsValues(EditableControls As Collection) As Collection
'Gibt die Werte der editierbaren Felder zurück.
Dim v As Variant
Dim coll As New Collection
Dim lst As ListBox
For Each v In EditableControls
If TypeName(v) = "ListBox" Then
Set lst = v 'Fehler 13: Typen unverträglich. v zur Laufzeit: Variant/Object/Listbox.
coll.Add GetCollectionString(GetSelected(lst))
Else
coll.Add v.Value
End If
Next
End Function
This is what I have so far:
Imagine that you have a module with the following code in it:
Option Explicit
Public Sub TestMe()
Dim colInput As New Collection
Dim colResult As Collection
Dim lngCount As Long
Dim ufMyUf As UserForm
Set ufMyUf = UserForm1
Set colInput = GetListBoxObjects(ufMyUf)
For lngCount = 1 To colInput.Count
Debug.Print colInput(lngCount).Name
Next lngCount
End Sub
Function GetListBoxObjects(uf As UserForm) As Collection
Dim colResult As New Collection
Dim objObj As Object
Dim ctrCont As Control
For Each ctrCont In uf.Controls
If LCase(Left(ctrCont.Name, 7)) = "listbox" Then
Set objObj = ctrCont
colResult.Add objObj
End If
Next ctrCont
Set GetListBoxObjects = colResult
End Function
If you run TestMe, you would get a collection of the ListBox objects. Anyhow, I am not sure how do you pass them to the collection function, thus I have decided to iterate over the UserForm and thus to check all of the objects on it.
Cheers!
I had problems with casting controls myself and didn't find a general solution that I could use easy.
Eventually I found the way to do it: store as "Object" makes it easy to convert to whatever type the control actually is.
I tested (and use) it
The sub below shows that it works (here : 1 TextBox; 1 ListBox; 1 ComboBox; 1 CommandButton on a worksheet)
Sub Test_Casting()
Dim lis As MSForms.ListBox
Dim txt As MSForms.TextBox
Dim btn As MSForms.CommandButton
Dim com As MSForms.ComboBox
Dim numObjects As Integer: numObjects = Me.OLEObjects.Count
Dim obj() As Object
ReDim obj(1 To numObjects) As Object
Dim i As Integer: i = 0
Dim cttl As OLEObject
For Each ctrl In Me.OLEObjects
i = i + 1
Set obj(i) = ctrl.Object
Next ctrl
Dim result As String
For i = 1 To numObjects
If TypeOf obj(i) Is MSForms.ListBox Then
Set lis = obj(i): result = lis.Name
ElseIf TypeOf obj(i) Is MSForms.TextBox Then
Set txt = obj(i): result = txt.Name
ElseIf TypeOf obj(i) Is MSForms.CommandButton Then
Set btn = obj(i): result = btn.Name
ElseIf TypeOf obj(i) Is MSForms.ComboBox Then
Set ComboBox = obj(i): result = com.Name
Else
result = ""
End If
If (Not (result = "")) Then Debug.Print TypeName(obj(i)) & " name= " & result
Next i
For i = 1 To numObjects
Set lis = IsListBox(obj(i))
Set txt = IsTextBox(obj(i))
Set btn = IsCommandButton(obj(i))
Set com = IsComboBox(obj(i))
result = ""
If (Not (lis Is Nothing)) Then
result = "ListBox " & lis.Name
ElseIf (Not (txt Is Nothing)) Then
result = "TexttBox " & txt.Name
ElseIf (Not (btn Is Nothing)) Then
result = "CommandButton " & btn.Name
ElseIf (Not (com Is Nothing)) Then
result = "ComboBox " & com.Name
End If
Debug.Print result
Next i
End Sub
Function IsListBox(obj As Object) As MSForms.ListBox
Set IsListBox = IIf(TypeOf obj Is MSForms.ListBox, obj, Nothing)
End Function
Function IsTextBox(obj As Object) As MSForms.TextBox
Set IsTextBox = IIf(TypeOf obj Is MSForms.TextBox, obj, Nothing)
End Function
Function IsComboBox(obj As Object) As MSForms.ComboBox
Set IsComboBox = IIf(TypeOf obj Is MSForms.ComboBox, obj, Nothing)
End Function
Function IsCommandButton(obj As Object) As MSForms.CommandButton
Set IsCommandButton = IIf(TypeOf obj Is MSForms.CommandButton, obj, Nothing)
End Function
One use for it is a class for handling events in one class.
Private WithEvents intEvents As IntBoxEvents
Private WithEvents decEvents As DecBoxEvents
Private genEvents As Object
Private genControl as OLEobject
Public sub Delegate(ctrl As OLEObject)
set genControl = ctrl
' Code for creating intEvents or decEvents
if .... create intevents.... then set genEvents = new IntEvents ' pseudo code
if .... create decevents.... then set genEvents = new DecEvents ' pseudo code
end sub
I hope this helps others that struggle with casting controls
With this code (in excel-vba) I add to a collection a number of items depending on an array.
I use the value of the array as key and the string "NULL" as value for each item added.
Dim Coll As New collection
Dim myArr()
Set Coll = New collection
myArr() = Array("String1", "String2", "String3")
For i = LBound(myArr) To UBound(myArr)
Coll.Add "NULL", myArr(i)
Next i
Now, if I want to change the value of an item, identifying it by the key, I must remove the item and then add an item with same key or is it possible to change the item value?
This below is the only way?
Coll.Remove "String1"
Coll.Add "myString", "String1"
Or is there something like: (I know that doesn't work)
Coll("String1") = "myString"
You can also write a (public) function to make updates to a collection.
public function updateCollectionWithStringValue(coll as Collection, key as string, value as string) as collection
coll.remove key
coll.add value, key
set updateCollectionWithStringValue = coll
end function
You can invoke this function by:
set coll = updateCollectionWithStringValue(coll, "String1","myString")
Then you have a one liner to invoke.
Can't you use the Before argument to fulfill this requirement?
Example:
Option Explicit
Sub TestProject()
Dim myStrings As New Collection
myStrings.Add item:="Text 1"
myStrings.Add item:="Text 2"
myStrings.Add item:="Text 3"
' Print out the content of collection "myStrings"
Debug.Print "--- Initial collection content ---"
PrintCollectionContent myStrings
' Or with the "Call" keyword: Call PrintCollectionContent(myStrings)
Debug.Print "--- End Initial collection content ---"
' Now we want to change "Text 2" into "New Text"
myStrings.Add item:="New Text", Before:=2 ' myStrings will now contain 4 items
Debug.Print "--- Collection content after adding the new content ---"
' Print out the 'in-between' status of collection "myStrings" where we have
' both the new string and the string to be replaced still in.
PrintCollectionContent myStrings
Debug.Print "--- End Collection content after adding the new content ---"
myStrings.Remove 3
' Print out the final status of collection "myStrings" where the obsolete
' item is removed
Debug.Print "--- Collection content after removal of the old content ---"
PrintCollectionContent myStrings
Debug.Print "--- End Collection content after removal of the old content ---"
End Sub
Private Sub PrintCollectionContent(ByVal myColl As Variant)
Dim i as Integer
For i = 1 To myColl.Count()
Debug.Print myColl.Item(i)
Next i
End Sub
Shouldn't this do the job?
Here is a solution where Coll("String1") = "myString" does work.
When you .Add an object to a VBA collection, the object itself is added, not its value. This means you can change the object's properties while it is in the collection. I've created a class module which wraps a single variant in a class object, with .Value as its default property. Save this to a .cls file, then File > Import File in the VBA editor.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsValue"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Private MyValue As Variant
Property Get Value() As Variant
Attribute Value.VB_UserMemId = 0
Value = MyValue
End Property
Property Let Value(v As Variant)
Attribute Value.VB_UserMemId = 0
MyValue = v
End Property
Now this version of your code works the way you had hoped:
Private Sub clsValue_test()
Dim Coll As New Collection
Dim myArr()
Dim v As Variant
myArr = Array("String1", "String2", "String3")
For Each v In myArr
Coll.Add New clsValue, v
Coll(v) = "NULL"
Next v
Coll("String1") = "myString" ' it works!
For Each v In myArr
Debug.Print v, ": "; Coll(v)
Next v
End Sub
Produces the result:
String1 : myString
String2 : NULL
String3 : NULL
A variant of making a function that deletes the collection item by its key, is implementing it as a VBA Property
Public Property Let CollectionValue(coll As Collection, key As String, value As String)
On Error Resume Next
coll.Remove key
On Error GoTo 0
coll.Add value, key
End Property
Public Property Get CollectionValue(coll As Collection, key As String) As String
CollectionValue = coll(key)
End Property
And Used like this
'Writing
CollectionValue(coll, "Date") = Now()
'Reading
Debug.Print(CollectionValue(coll, "Date"))
By ignoring if key not exists, it can be used to add items as well
just loop the collection and add the new values to a new collection...
function prep_new_collection(my_old_data as collection) as collection
dim col_data_prep as new collection
for i = 1 to my_old_data.count
if my_old_data(i)(0)= "whatever" then
col_data_prep.add array("NULL", my_old_data(i)(1))
else
col_data_prep.add array(my_old_data(i)(0), my_old_data(i)(1))
end if
next i
set prep_new_collection = col_data_prep
end function
I just ran into the same issue an thought to post my solution here for any one who might need it. my solution was to make a class called
EnhancedCollection that has an update function. save this code to a file named EnhancedCollection.cls and then import into your project.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "EnhancedCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private data As New Collection
'=================================ADD
If IsMissing(key) Then
If IsMissing(before) Then
If IsMissing(after) Then
data.Add Value
Else
data.Add Value, , , after
End If
Else
data.Add Value, , before
End If
ElseIf key = "TEMP_ITEM" Then
Exit Sub
Else
If IsMissing(before) Then
If IsMissing(after) Then
data.Add Value, key
Else
data.Add Value, key, , after
End If
Else
data.Add Value, key, before
End If
End If
End Sub
'=================================REMOVE
Sub Remove(key As Variant)
data.Remove key
End Sub
'=================================COUNT
Function Count() As Integer
Count = data.Count
End Function
'=================================ITEM
Function Item(key As Variant) As Variant
'This is the default Function of the class
Attribute Item.VB_Description = "returns the item"
Attribute Item.VB_UserMemId = 0
On Error GoTo OnError
If VarType(key) = vbString Or VarType(key) = vbInteger Then
Item = data.Item(key)
End If
Exit Function
OnError:
Item = Null
End Function
'=================================Update
Function Update(key As Variant, Value As Variant) As Variant
On Error GoTo OnError
If VarType(key) = vbString Or VarType(key) = vbInteger Then
data.Add "", "TEMP_ITEM", , key
data.Remove key
data.Add Value, key, "TEMP_ITEM"
data.Remove "TEMP_ITEM"
End If
Exit Function
OnError:
Update = Null
End Function
And as an added benefit, you can always add more functionality.