Using Access 2010, I'm gathering information and dropping it on an Excel spreadsheet. When I run the code below, I'm getting
Run-time error '91':Object variable or With block not set
in my class on this line Set Cci = ChartColorItems(ColorID) in Public Function GetRGB(ByRef ColorID As String) As Integer
The 'ChartColors' class:
Option Compare Database
Option Explicit
Private pChartColorItems As Collection
Public Property Get ChartColorItems() As Collection
Set ChartColorItems = pChartColorItems
End Property
Public Property Set ChartColorItems(ByRef lChartColorItem As Collection)
Set pChartColorItems = lChartColorItem
End Property
Public Function GetRGB(ByRef ColorID As String) As Integer
Dim Cci As ChartColorItem
Dim x As Integer
'---------------------------------------------------
'Error happens here:
Set Cci = ChartColorItems(ColorID)
'---------------------------------------------------
x = RGB(Cci.Red, Cci.Green, Cci.Blue)
GetRGB = x
Set Cci = Nothing
End Function
Private Sub Class_Initialize()
Dim Cci As ChartColorItem
Dim Colors As Collection
Set Colors = New Collection
Set Cci = New ChartColorItem
Cci.Red = 149
Cci.Green = 55
Cci.Blue = 53
Cci.ColorID = "Pie1"
Colors.Add Cci, Key:=Cci.ColorID
Set Cci = Nothing
Set Cci = New ChartColorItem
Cci.Red = 148
Cci.Green = 138
Cci.Blue = 84
Cci.ColorID = "Pie2"
Colors.Add Cci, Key:=Cci.ColorID
Set Cci = Nothing
End Sub
and the ChartColorItem class:
Option Compare Database
Option Explicit
Private pColorID As String
Private pRed As Integer
Private pGreen As Integer
Private pBlue As Integer
Public Property Get ColorID() As String
ColorID = pColorID
End Property
Public Property Let ColorID(ByRef x As String)
pColorID = x
End Property
Public Property Get Red() As Integer
Red = pRed
End Property
Public Property Let Red(ByRef x As Integer)
pRed = x
End Property
Public Property Get Green() As Integer
Green = pGreen
End Property
Public Property Let Green(ByRef x As Integer)
pGreen = x
End Property
Public Property Get Blue() As Integer
Blue = pBlue
End Property
Public Property Let Blue(ByRef x As Integer)
pBlue = x
End Property
When I debug, the code steps through the ChartColorItems() getter just fine, the error happens after the End Function, and drops me on the line noted above.
This is very similar to some code I wrote earlier this week, the main difference is that I'm populating my ChartColors by using the Class_Initialize sub, since I'm trying to store off a fixed set of colors, whereas my earlier code was gathering data and inserting it into the class in a more 'normal' way.
You defined the private collection at the module level as pCharColorItems, but you never initialize it in the class' intialize method. Instead, you use a locally scoped Colors collection variable.
Private Sub Class_Initialize()
Dim Cci As ChartColorItem
Dim Colors As Collection
Set Colors = New Collection
You need to use pChartColorItems instead.
Private Sub Class_Initialize()
Dim Cci As ChartColorItem
Dim Colors As Collection
Set pChartColorItems = New Collection
Set Cci = New ChartColorItem
Cci.Red = 149
Cci.Green = 55
Cci.Blue = 53
Cci.ColorID = "Pie1"
pChartColorItems.Add Cci, Key:=Cci.ColorID
Set Cci = Nothing
Set Cci = New ChartColorItem
Cci.Red = 148
Cci.Green = 138
Cci.Blue = 84
Cci.ColorID = "Pie2"
pChartColorItems.Add Cci, Key:=Cci.ColorID
Set Cci = Nothing
End Sub
But there's another bug on this line of GetRGB.
x = RGB(Cci.Red, Cci.Green, Cci.Blue)
You declared x as an Integer, when the RGB function returns a long. The value of "Pie1" causes an overflow error.
Related
I am trying to loop over the items in a dictionary with an object variable that refer to inheritance class "Breed", but I am unable to do so with dictionaries but with collections it is pretty simple is there a way to solve this without using the dictionary's keys? because then I will lose the ability to use the intelisense feature.
Here is the code of the class Breed:
Option Explicit
Public Property Get Name() As String
End Property
Public Property Get Color() As String
End Property
Public Property Get Price() As Double
End Property
Here is the code for class Dogs:
Option Explicit
Implements Breed
Private pName As String, pPrice As Double, pColor As String
Public Property Let Name(Val As String)
pName = Val
End Property
Public Property Get Name() As String
Name = pName
End Property
Private Property Get Breed_Name() As String
Breed_Name = Name
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Let Price(Val As Double)
pPrice = Val
End Property
Public Property Get Price() As Double
Price = pPrice
End Property
Private Property Get Breed_Price() As Double
Breed_Price = Price
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Let Color(Val As String)
pColor = Val
End Property
Public Property Get Color() As String
Color = pColor
End Property
Private Property Get Breed_Color() As String
Breed_Color = Color
End Property
Here is the code for class Cats:
Option Explicit
Implements Breed
Private pName As String, pPrice As Double, pColor As String
Public Property Let Name(Val As String)
pName = Val
End Property
Public Property Get Name() As String
Name = pName
End Property
Private Property Get Breed_Name() As String
Breed_Name = Name
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Let Price(Val As Double)
pPrice = Val
End Property
Public Property Get Price() As Double
Price = pPrice
End Property
Private Property Get Breed_Price() As Double
Breed_Price = Price
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Let Color(Val As String)
pColor = Val
End Property
Public Property Get Color() As String
Color = pColor
End Property
Private Property Get Breed_Color() As String
Breed_Color = Color
End Property
Here is the code for the regular module with collection but fails with dictionary:
Option Explicit
Sub Main()
Dim C As Cats
Dim D As Dogs
Dim Coll As Collection
Dim B As Breed
Set C = New Cats
C.Name = "Catomon"
C.Color = "Angle White"
C.Price = 800.98
Set D = New Dogs
D.Name = "Dogomon"
D.Color = "Golden White"
D.Price = 1000.23
Set Coll = New Collection
Coll.Add C
Coll.Add D
Set B = New Breed
For Each B In Coll
Debug.Print B.Name, B.Color, B.Price
Next B
Set C = Nothing
Set D = Nothing
Set B = Nothing
Set Coll = Nothing
End Sub
Dictionary methods .Keys() and .Items() return arrays. Only way to iterate over arrays is with an variable of type Variant. With these restrictions, the only way I can think of is casting Variant variable to the type Breed inside the loop. This way, after the casting, you get Intellisense.
Based on the code you posted, an example would be:
Sub MainWithDictionary()
Dim C As Cats
Dim D As Dogs
Dim Dict As Scripting.Dictionary
Dim B As Breed
Dim K As Variant 'new variable
Set C = New Cats
C.Name = "Catomon"
C.Color = "Angle White"
C.Price = 800.98
Set D = New Dogs
D.Name = "Dogomon"
D.Color = "Golden White"
D.Price = 1000.23
Set Dict = New Scripting.Dictionary
'Keys are just placeholders
Dict.Add 1, C
Dict.Add 2, D
For Each K In Dict.Items()
'Cast the Variant result to Breed
Set B = K
'You will have Intellisense on each dictionary items after this
Debug.Print B.Name, B.Color, B.Price
Next K
Set C = Nothing
Set D = Nothing
Set B = Nothing
Set Dict = Nothing
End Sub
sorry if similar has already been posted - I couldn't find one.
I have a need to have a collection of classes that each contains a collection of classes. There's expected to be a few hundred thousand entries to the collections.
I am finding it's taking ~1 second to create all of the collections, but taking ~minutes to delete them afterwards.
Below is a snippet of random code that creates the issue I'm seeing.
Is this expected? Why does it take ~100 times longer to delete the collections vs creating it. Is there any way of speeding it up?
Thanks
Module1:
Private p_main_collection As Collection
Sub main()
Debug.Print "Starting: " & Now()
Set p_main_collection = New Collection
Dim i As Long
Dim j As Long
Dim v_class1 As Class1
Dim v_class2 As Class2
For i = 1 To 8
Set v_class1 = New Class1
p_main_collection.Add v_class1
v_class1.Num = i
For j = 1 To 50000
Set v_class2 = New Class2
v_class2.Num = j
v_class1.add_to_collection = v_class2
Next j
Next i
Debug.Print "Deleting: " & Now()
Set p_main_collection = Nothing
Debug.Print "Deleted: " & Now()
End Sub
Class1
Private p_num As Integer
Private p_collection As Collection
Private Sub Class_Initialize()
Set p_collection = New Collection
End Sub
Public Property Let Num(p_num_in As Integer)
p_num = p_num_in
End Property
Public Property Get Num() As Integer
Num = p_num
End Property
Public Property Let add_to_collection(p_collection_in As Class2)
p_collection.Add p_collection_in
End Property
Class2
Private p_num As Long
Public Property Let Num(p_num_in As Long)
p_num = p_num_in
End Property
Public Property Get Num() As Long
Num = p_num
End Property
Result
Starting: 08/01/2019 23:15:01
Deleting: 08/01/2019 23:15:02
Deleted: 08/01/2019 23:16:19
I am trying to implement a Model-View-Presenter Userinterface in VBA excel. In order to do this I have been writing different Model classes. Here an Example:
Option Explicit
Private Type TModel
FilterCol As Collection
N As Integer
End Type
Private this As TModel
Public Property Get FilterCol() As Collection
Set FilterCol = this.FilterCol
End Property
Public Property Let FilterCol(ByVal value As Collection)
Set this.FilterCol = value
End Property
Public Property Get N() As Integer
Set N = this.N
End Property
Public Property Let N(ByVal value As Integer)
Set this.N = value
End Property
This class called "FilterModel" is a collection of MSFormObjects. In order to use the collection properly I need to new it. So the code where I use it would look a little like this:
Sub testFilter()
Dim Filterm As FilterModel
Dim DefaultFilterLine As New FilterLine
Set Filterm = New FilterModel
Filterm.FilterCol = New Collection
'Set DefaultFilter
Filterm.FilterCol.Add DefaultFilterLine
'DoStuff
With New frmFilter
Set .Model = Filterm
.Show
End With
End Sub
If I don't new the Property FilterCol before I add something, in this case the defaultfilter, it doesn't work. So here is my Question:
Is there a way to overwrite the new statement for my new class in order to have it also new up the collection FilterCol. My research got me as far as I now know that this would be called a constructor.
But how would one properly implement a constructor for a VBA class?
Somthing like:
Private Sub Class_Initialize()
Set this.FilterCol = New Collection
N = 0
End Sub
If I do this then I get an error in the "Property Let N(Byval Value as integer)" Line. The error message reads "object required".
Here is a working solution. I suggest going through the code line-by-line using F8 to understand what is happening there. Debug.print prints values into the Immediate window.
Here is the FilterModel class:
''' FilterModel class
Option Explicit
Private pFilterCol As Collection
Private pN As Integer
Public Property Get FilterCol() As Collection
Set FilterCol = pFilterCol
End Property
Public Property Let FilterCol(ByVal value As Collection)
Set pFilterCol = value
End Property
Public Property Get N() As Integer
N = pN
End Property
Public Property Let N(ByVal value As Integer)
pN = value
End Property
Private Sub Class_Initialize()
Set pFilterCol = New Collection
pN = 0
End Sub
and here is module code to test it:
''' random module
Option Explicit
Sub testFilter()
Dim Filterm As FilterModel
Set Filterm = New FilterModel
Filterm.FilterCol = New Collection
''' default values (specified in Class_Initialize())
Debug.Print Filterm.N
Debug.Print Filterm.FilterCol.Count
''' set the values through Property Let
Filterm.FilterCol.Add "whatever"
Filterm.FilterCol.Add "whenever"
Filterm.N = 6
''' print the new values (through Property Get)
Debug.Print Filterm.N
Debug.Print Filterm.FilterCol.Count
Debug.Print Filterm.FilterCol(1)
Debug.Print Filterm.FilterCol(2)
End Sub
I currently have instances of classes stored using the data structure presented in the image below. Each -List item is a dictionary and each -Info item is an instance of a class.
I read elsewhere that if you Set an instance variable equal to another instance, it just references the original instance. Is this correct?
I have been able to create a reference for fileInfo(1) (in the image) using the following code.
Dim prflInfo As File_Info
Set prflInfo = New File_Info
Set prflInfo = fileList.Items(0)
I have attempted to reference the branchInfo instance using the following code, but I get a Run-time error 13: Type mismatch when I attempt to do so.
Dim prbrInfo As Branch_Info
With prflInfo
Set prbrInfo = New Branch_Info
brKey = .getbrKey(0)
Set prbrInfo = .getbrItem(brKey)
End With
Edit: Included below is the code for the File_Info class. All other classes follow this basic model.
'Class Module: File_Info
'Initialise class variables
Private pfileID As Integer
Private pfilePath As String
Private pfileName As String
Private pbranchList As Scripting.Dictionary
'Declare variantcopy subroutine
Private Declare Sub VariantCopy Lib "OleAut32" (pvarDest As Any, pvargSrc As Any)
Private Sub Class_Initialize()
Set pbranchList = New Scripting.Dictionary
End Sub
Public Property Let fileID(pfileIDi As Variant)
pfileID = pfileIDi
End Property
Public Property Get fileID() As Variant
fileID = pfileID
End Property
Public Property Let filePath(pfilePathi As Variant)
pfilePath = pfilePathi
End Property
Public Property Get filePath() As Variant
filePath = pfilePath
End Property
Public Property Let fileName(pfileNamei As Variant)
pfileName = pfileNamei
End Property
Public Property Get fileName() As Variant
fileName = pfileName
End Property
Public Sub addbrConn(branch As Branch_Info)
pbranchList.Add branch.branchID, branch.brConn
Debug.Print "addbrConn ID: " & branch.branchID
End Sub
Public Sub addBranch(branch As Branch_Info)
pbranchList.Add branch.branchID, branch
Debug.Print pbranchList.Count
End Sub
Public Function countbrList()
countbrList = pbranchList.Count
End Function
Public Function getbrKey(Key As Variant)
getbrKey = pbranchList.Keys(Key)
End Function
Public Function getbrItem(Key As Variant)
getbrItem = GetByRefVariant(pbranchList.Items(Key))
End Function
Public Sub dpbrList()
With pbranchList
Debug.Print pbranchList.Count
For k = 1 To pbranchList.Count
Debug.Print .Keys(k - 1), .Items(k - 1)
Next k
End With
End Sub
Public Sub updbrList(branch As Branch_Info)
Dim branchID As String
branchID = branch.branchID
If pbranchList.exists(branchID) Then
pbranchList.Remove (branchID)
pbranchList.Add branchID, branch
Debug.Print "Complete: " & branchID & " added."
Else
Debug.Print "Error: " & branchID & "does not exist."
End If
End Sub
Private Function GetByRefVariant(ByRef var As Variant) As Variant
VariantCopy GetByRefVariant, var
End Function
Is there a way to reference the branchInfo class, to make it easier to extract the data within it?
Thanks!
Eeshwar
I do things differently in that I iterate through the keys list using a For ... each loop rather than referring to an item number. Here is a snippet that works using two levels.
You can ignore the lines where the property values are written to an array, but they were part of the original code.
cf.Dependents is a dictionary of cDependents within the cFamily object
'Declarations in Main Module
Dim dF As Dictionary, cF As cFamily, cD As cDependents
Dim I As Long, J As Long
Dim V As Variant, W As Variant
...
For Each V In dF
I = I + 1
Set cF = dF(V)
With cF
vRes(I, 1) = .FirstName
vRes(I, 2) = .LastName
vRes(I, 3) = .Birthdate
J = 2
For Each W In .Dependents
J = J + 2
Set cD = .Dependents(W)
With cD
vRes(I, J) = .Relation
vRes(I, J + 1) = .DepName
End With
Next W
End With
Next V
Note that in the sequence, as you show in your question:
set Obj = new Obj
set Obj = myClass(0)
the first line is unnecessary.
IMO it is possible to use simple VBA.Collection, here example for the FileList and BranchList. In this example List classes have Items and Info classes have reference to List where List is wrapper for a VBA.Collection. HTH
For more reading have a look e.g. here.
FileList Class
Option Explicit
Private m_fileInfoCollection As FileInfoCollection
Private Sub Class_Initialize()
Set m_fileInfoCollection = New FileInfoCollection
End Sub
Public Property Get Items() As FileInfoCollection
Set Items = m_fileInfoCollection
End Property
FileInfo Class
Option Explicit
Private m_branchList As BranchList
Private m_fileID As Integer
Private Sub Class_Initialize()
Set m_branchList = New BranchList
End Sub
Public Property Get FileID() As Integer
FileID = m_fileID
End Property
Public Property Let FileID(ByVal vNewValue As Integer)
m_fileID = vNewValue
End Property
Public Property Get BranchList() As BranchList
Set BranchList = m_branchList
End Property
FileInfoCollection Class
Option Explicit
Private m_collection As VBA.Collection
Private Sub Class_Initialize()
Set m_collection = New VBA.Collection
End Sub
Public Sub Add(ByVal newItem As FileInfo)
m_collection.Add newItem, CStr(newItem.FileID)
End Sub
Public Function ItemByKey(ByVal key As String) As FileInfo
Set ItemByKey = m_collection(key)
End Function
Public Function ItemByIndex(ByVal index As Long) As FileInfo
Set ItemByIndex = m_collection(index)
End Function
Public Function Count() As Long
Count = m_collection.Count
End Function
BranchList Class
Option Explicit
Private m_branchInfoCollection As BranchInfoCollection
Private Sub Class_Initialize()
Set m_branchInfoCollection = New BranchInfoCollection
End Sub
Public Property Get Items() As BranchInfoCollection
Set Items = m_branchInfoCollection
End Property
BranchInfo Class
Option Explicit
Private m_branchID As Integer
Public Property Get branchID() As Integer
branchID = m_branchID
End Property
Public Property Let branchID(ByVal vNewValue As Integer)
m_branchID = vNewValue
End Property
BranchInfoCollection Class
Option Explicit
Private m_collection As VBA.Collection
Private Sub Class_Initialize()
Set m_collection = New VBA.Collection
End Sub
Public Sub Add(ByVal newItem As BranchInfo)
m_collection.Add newItem, CStr(newItem.branchID)
End Sub
Public Function ItemByKey(ByVal key As String) As BranchInfo
Set ItemByKey = m_collection(key)
End Function
Public Function ItemByIndex(ByVal index As Long) As BranchInfo
Set ItemByIndex = m_collection(index)
End Function
Public Function Count() As Long
Count = m_collection.Count
End Function
Standard Module
Option Explicit
Sub Demo()
' Fill
Dim bi As BranchInfo
Set bi = New BranchInfo
bi.branchID = 111
Dim fi As FileInfo
Set fi = New FileInfo
fi.FileID = 222
fi.BranchList.Items.Add bi
Dim fl As FileList
Set fl = New FileList
fl.Items.Add fi
' Get
Dim fi1 As FileInfo
Set fi1 = fl.Items.ItemByIndex(1)
Dim bi1 As BranchInfo
Set bi1 = fi1.BranchList.Items(1)
End Sub
I am trying to set up a custom object model using an example I found in an answered question here on stackoverflow.
VBA Classes - How to have a class hold additional classes
Here is the code I have created based on the answer.
Standard Module
Sub test()
Dim i As Long
Dim j As Long
'code to populate some objects
Dim AssemList As Collection
Dim Assem As cAssem
Dim SubAssemList As Collection
Dim SubAssem As cSubAssem
Set AssemList = New Collection
For i = 1 To 3
Set SubAssemList = New Collection
Set Assem = New cAssem
Assem.Description = "Assem " & i
For j = 1 To 3
Set SubAssem = New cSubAssem
SubAssem.Name = "SubAssem" & j
SubAssemList.Add SubAssem
Next j
Set Assem.SubAssemAdd = SubAssemList '<------ Object variable or With Block not Set
AssemList.Add Assem
Next i
Set SubAssemList = Nothing
'write the data backout again
For Each clock In AssemList
Debug.Print Assem.Description
Set SubAssemList = Assem.SubAssems
For Each SubAssem In SubAssemList
Debug.Print SubAssem.Name
Next
Next
End Sub
cAssem Class
Private pDescription As String
Private pSubAssemList As Collection
Private Sub Class_Initialize()
Set pSubAssems = New Collection
End Sub
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(ByVal sDescription As String)
pDescription = sDescription
End Property
Public Property Get SubAssems() As Collection
Set SubAssems = pSubAssemList
End Property
Public Property Set SubAssemAdd(AssemCollection As Collection)
For Each AssemName In AssemCollection
pSubAssemList.Add AssemName ' <------- This is the line that is triggering the error
Next
End Property
cSubAssem Class
Private pSubAssemName As String
Public Property Get Name() As String
Name = pSubAssemName
End Property
Public Property Let Name(ByVal sName As String)
pSubAssemName = sName
End Property
I have not changed anything in the code except class names and variable names and from my limited point of view I cannot understand the cause of the error.
I am just starting to really dig into objects and Class Modules in VBA so I appreciate any knowledge this community could pass my way.
Many Thanks
You have a typo in your sub class initializer:
Private Sub Class_Initialize()
Set pSubAssems = New Collection
End Sub
should read:
Private Sub Class_Initialize()
Set pSubAssemList = New Collection
End Sub