How to handle a function where the returned value type is not known at run-time (Object or Non-Object) - vba

This question centers around the return value of a call to CallByName. I have a class called PropertyPtr which is meant to act as a generic pointer to an object property. It holds a reference to an Object, and the name of one of its properties. It exposes a Getter and Setter method.
PropertyPtr:
Option Explicit
Public Obj As Object
Public PropertyName As String
Public Sub Setter(Val As Variant)
If IsObject(Val) Then
CallByName Me.Obj, Me.PropertyName, VbSet, Val
Else
CallByName Me.Obj, Me.PropertyName, VbLet, Val
End If
End Sub
Public Function Getter() As Variant
If IsObject(CallByName(Me.Obj, Me.PropertyName, VbGet)) Then
Set Getter = CallByName(Me.Obj, Me.PropertyName, VbGet)
Else
Getter = CallByName(Me.Obj, Me.PropertyName, VbGet)
End If
End Function
In the Getter, my CallByName could return a object or not. But the only way I can see to test if the CallByName value will be an object is to end up running it twice - once to test inside an IsObject and then again to get a reference to the value. The only other way I could see doing this is trapping for an error. Then, you at least only SOMETIMES run the CallByName twice.
My question is: is there some other way to do this without running CallByName twice?

Okay, so if you really want to follow that route then I think you'll have to set an IsObj flag - probably at the point you set the property name.
However, I'd still maintain that using a Variant for either an Object or primitive type isn't a great idea, and the CallByName() function in this context comes with issues. My hesitations are that performance will be diminished and you'll have quite a task to keep the property strings aligned with the property names (should you update things in the future).
It is possible to implement a Mediator Pattern in VBA and I do feel you should consider this route. Below is a really basic example of how you could do it. I haven't bothered with an interface for the mediator, but I have created an interface for my participating classes (to cover the possibility that you're dealing with your own 'groups' of classes).
Mediator class (called cMediator):
Option Explicit
Private mSweets As Collection
Private Sub Class_Initialize()
Set mSweets = New Collection
End Sub
Public Sub RegisterSweet(sweet As ISweet)
Set sweet.Mediator = Me
mSweets.Add sweet
End Sub
Public Sub SendSugarLimit(limit As Long)
Dim sweet As ISweet
For Each sweet In mSweets
sweet.ReceiveSugarLimit limit
Next
End Sub
Public Sub ReceiveMeltingAlert(offender As String)
Dim sweet As ISweet
For Each sweet In mSweets
sweet.ReceiveEatNow offender
Next
End Sub
Participating classes Interface (called ISweet):
Option Explicit
Public Property Set Mediator(RHS As cMediator)
End Property
Public Sub ReceiveSugarLimit(g_perDay As Long)
End Sub
Public Sub ReceiveEatNow(offender As String)
End Sub
My two participating classes (cQtySweet and cWeightSweet):
Option Explicit
Implements ISweet
Public Name As String
Public SugarPerItem As Long
Public CanMelt As Boolean
Private pMediator As cMediator
Public Sub OhNoItsMelting()
pMediator.ReceiveMeltingAlert Name
End Sub
Private Property Set ISweet_Mediator(RHS As cMediator)
Set pMediator = RHS
End Property
Private Sub ISweet_ReceiveEatNow(offender As String)
If CanMelt Then Debug.Print offender & " is melting. Eat " & Name & "s now!"
End Sub
Private Sub ISweet_ReceiveSugarLimit(g_perDay As Long)
Dim max As Long
max = g_perDay / SugarPerItem
Debug.Print "Max " & Name & "s: " & max & "."
End Sub
Option Explicit
Implements ISweet
Public Name As String
Public SugarPer100g As Long
Public CanMelt As Boolean
Private pMediator As cMediator
Public Sub OhNoItsMelting()
pMediator.ReceiveMeltingAlert Name
End Sub
Private Property Set ISweet_Mediator(RHS As cMediator)
Set pMediator = RHS
End Property
Private Sub ISweet_ReceiveEatNow(offender As String)
If CanMelt Then Debug.Print offender & " is melting. Eat " & Name & " now!"
End Sub
Private Sub ISweet_ReceiveSugarLimit(g_perDay As Long)
Dim max As Long
max = g_perDay / (SugarPer100g / 100)
Debug.Print "Max " & Name & ": " & max & "g."
End Sub
Module Code:
Public Sub RunMe()
Dim m As cMediator
Dim qtySweet As cQtySweet
Dim weightSweet As cWeightSweet
Set m = New cMediator
Set qtySweet = New cQtySweet
With qtySweet
.Name = "Gobstopper"
.SugarPerItem = 5
.CanMelt = False
End With
m.RegisterSweet qtySweet
Set qtySweet = New cQtySweet
With qtySweet
.Name = "Wine Gum"
.SugarPerItem = 2
.CanMelt = True
End With
m.RegisterSweet qtySweet
Set weightSweet = New cWeightSweet
With weightSweet
.Name = "Sherbert"
.SugarPer100g = 80
.CanMelt = False
End With
m.RegisterSweet weightSweet
Set weightSweet = New cWeightSweet
With weightSweet
.Name = "Fudge"
.SugarPer100g = 50
.CanMelt = True
End With
m.RegisterSweet weightSweet
'Blasted government has reduced sugar allowance.
Debug.Print "New govt. limits..."
m.SendSugarLimit 200
'Phew what a scorcher - the fudge is melting in my pocket.
Debug.Print "Sweet alarm..."
weightSweet.OhNoItsMelting
End Sub
… and the output looks like this:
New govt. limits...
Max Gobstoppers: 40.
Max Wine Gums: 100.
Max Sherbert: 250g.
Max Fudge: 400g.
Sweet alarm...
Fudge is melting. Eat Wine Gums now!
Fudge is melting. Eat Fudge now!

Related

Putting Excel Tables into a Custom Class

I'm new to using VBA classes, and I think what I want to do -- using them with ListObjects -- is more of an "intermediate" than "beginner" technique.
Let's say I have two tables related to cars.
tblCarDesc
ID MAKE MODEL DOORS ENGINE
1 Chevrolet Corvette 2 V8
2 Ford Escort 4 V6
3 Rolls-Royce SilverCloud 4 V8
tblCarProd
ID COUNTRY TYPE
1 US Sport
2 US Economy
3 UK Luxury
(The same cars are in both tables, and shown by the ID numbers.)
I want to have a class called objCars that includes the fields (columns) from both tables. That way, when referring to Car #3, objCars.Make would be "Rolls-Royce" and objCars.Type would be "Luxury".
1) Is there a way to import both tables into objCars?
Perhaps I would create an array big enough to hold all the columns, then load both tables into it. The tutorial I've been reading says that I would then create a Collection, loop through each row of the array, make a new instance of objCars, and assign objCars.Make, objCars.Model, etc., for each row. Then each item of the Collection would contain a car. (Or something like that. I don't really know much about Collections either.) If that's right, is it the best way?
2) How exactly does one refer to a specific car? The examples I've read like to loop through Collections and work on each item therein, but what if I want to extract a particular item? I know the Ford is Car #2; how do I get the objCars.Make and objCars.Model for that particular ID number?
I would have two classes. A class clsCar for one car and a class clsCars for a collection of cars.
Each of this classes may have setter and getter methods and also may have custom methods if needed. Especially the clsCars should have a set of getBy...-methods to get a car or a collection of cars from the collection by criterion.
Example:
clsCar:
Private pID As Long
Private pMAKE As String
Private pMODEL As String
Private pDOORS As Integer
Private pENGINE As String
Private pCOUNTRY As String
Private pTYPE As String
Public Property Get ID() As Long
ID = pID
End Property
Public Property Let ID(Value As Long)
pID = Value
End Property
Public Property Get MAKE() As String
MAKE = pMAKE
End Property
Public Property Let MAKE(Value As String)
pMAKE = Value
End Property
Public Property Get MODEL() As String
MODEL = pMODEL
End Property
Public Property Let MODEL(Value As String)
pMODEL = Value
End Property
Public Property Get DOORS() As Integer
DOORS = pDOORS
End Property
Public Property Let DOORS(Value As Integer)
pDOORS = Value
End Property
Public Property Get ENGINE() As String
ENGINE = pENGINE
End Property
Public Property Let ENGINE(Value As String)
pENGINE = Value
End Property
Public Property Get COUNTRY() As String
COUNTRY = pCOUNTRY
End Property
Public Property Let COUNTRY(Value As String)
pCOUNTRY = Value
End Property
Public Property Get CarTYPE() As String
CarTYPE = pTYPE
End Property
Public Property Let CarTYPE(Value As String)
pTYPE = Value
End Property
Public Function toString() As String
toString = pID & "; " & _
pMAKE & "; " & _
pMODEL & "; " & _
pDOORS & "; " & _
pENGINE & "; " & _
pCOUNTRY & "; " & _
pTYPE
End Function
clsCars:
Private pCars As collection
Private Sub Class_Initialize()
Set pCars = New collection
End Sub
Public Sub add(oCar As clsCar)
pCars.add oCar
End Sub
Public Function getByIndex(lIndex As Long) As clsCar
Set getByIndex = pCars.Item(lIndex)
End Function
Public Function getByID(lID As Long) As clsCar
Dim oCar As clsCar
For Each oCar In pCars
If oCar.ID = lID Then
Set getByID = oCar
End If
Next
End Function
Public Function getByEngine(sEngine As String) As collection
Dim oCar As clsCar
Set getByEngine = New collection
For Each oCar In pCars
If oCar.ENGINE = sEngine Then
getByEngine.add oCar
End If
Next
End Function
default Module:
Public oCars As clsCars
Sub initialize()
Dim oCar As clsCar
Dim oListObject As ListObject
Dim oListRow As ListRow
Dim oCells As Range
Set oCars = New clsCars
Set oListObject = Worksheets("Sheet1").ListObjects("tblCarDesc")
For Each oListRow In oListObject.ListRows
Set oCells = oListRow.Range.Cells
Set oCar = New clsCar
oCar.ID = oCells(, 1).Value
oCar.MAKE = oCells(, 2).Value
oCar.MODEL = oCells(, 3).Value
oCar.DOORS = oCells(, 4).Value
oCar.ENGINE = oCells(, 5).Value
oCars.add oCar
Next
Set oListObject = Worksheets("Sheet1").ListObjects("tblCarProd")
Dim lID As Long
For Each oListRow In oListObject.ListRows
Set oCells = oListRow.Range.Cells
lID = oCells(, 1).Value
Set oCar = oCars.getByID(lID)
If Not oCar Is Nothing Then
oCar.COUNTRY = oCells(, 2).Value
oCar.CarTYPE = oCells(, 3).Value
End If
Next
MsgBox oCars.getByIndex(2).toString
For Each oCar In oCars.getByEngine("V8")
MsgBox oCar.toString
Next
End Sub
I would use a class for each, and an array of each also, so arrCars holds clsCars, and arrProd holds clsProduction. I would then use the index of each for each array when populating, so arrCars(1)=Corvette and arrProd(1)=US Sport then from each you can refer to the others, so if x=3, cars(x) and prod(x) will be correct. Or use a vlookup in excel first, and make one larger table, with the need for only 1 ID then, if that is the way they are related, but can a Bentley also be 3. Its not quite clear what you mean by the 2nd table, is there an entry for each car, or is it like catgeorising the car further, just using a certain selection. Another idea would be to have an extra property in the car class, of ProductionID and then use a static production "table" of classes to refer to.

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.

How do I declare a constant variable with a value of a function call

In a VBA module I have the following declaration of constants:
Private Const const_abc = 3000
Private Const const_def = 900
Private Const const_etc = 42
' and so on and so forth
Now, I have to initialize these values with a one time function call, ideally something like so
Private Const const_abc = someFunc(18)
Private Const const_def = someFunc( 7)
Private Const const_etc = someFunc( 5)
' and so on and so forth
Of course, this won't work in VBA. So, is there a common pattern on how to deal with such a requirement?
I probably could go like so
Private const_abc As Double
Private const_def As Double
Private const_etc As Double
sub initConsts()
const_abc = someFunc(18)
const_def = someFunc( 7)
const_etc = someFunc( 5)
end sub
But then I'd have to make sure that initConsts is called which I'd rather not do.
Edit As per the question of S O, I am using MS-Access.
Create a class that reads the cell and presents a Get-only interface to the value.
Here's a class called ItsMyValueClass
Option Explicit
Private pMyVal As Integer
Public Property Get MyValue() As Integer
MyValue = pMyVal
End Property
Private Sub class_initialize()
'pMyVal = Sheet.Range("somewhere)
pMyVal = 17
End Sub
And here's the code in your module:
Option Explicit
Sub IsItReadOnly()
Dim valu As ItsMyValueClass
Dim x As Integer
Set valu = New ItsMyValueClass
x = valu.MyValue
'valu.MyValue = 23 'compile error "Can't assign to read-only property"
End Sub
Public Function White() as Long
White = RGB(255,255,255)
End function
Private Sub TestIt()
Debug.Print "White is " & White
White = 123 ' <-- compile error
End Sub
in a one-liner that works with modules and classes alike for pure constant-like access:
Public Property Get myConst() As Integer: myConst = 3: End Property
you would use it like this:
Sub test()
Debug.Print "myConst: " & myConst 'would print: "myConst: 3"
End Sub
and if it has to be initialized with a custom value once, one could do it with a static property and one or many private variables:
Private ci As Boolean 'constants initialized
Private myConst1_ As Integer
Private myConst2_ As Integer
Static Property Get myConst1() As Integer
If Not ci Then init
myConst1 = myConst1_
End Property
Static Property Get myConst2() As Integer
If Not ci Then init
myConst2 = myConst2_
End Property
Private Sub init()
'these can come from anywhere:
myConst1_ = 3
myConst2_ = 5
ci = True
End Sub
they are initialized on the first access of the first "constant" property
if you have to initialize them earlier one could just call the init function earlier (and optionally remove the ci variable and all related lines if it is ensured that the properties are not accessed earlier)

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.

Access variables of sub in VBA

I have the following sub
Public Static Sub Varib()
Device_ = Sheet1.DeviceType_.Text
Model_ = Sheet1.Model_.Text
Security_ = Sheet1.SecurityGroup_.Text
Catagory_ = Application.Index(Worksheets("Temp_for_varible_lists").Range("b:b"), Application.Match(x, Worksheets("Temp_for_varible_lists").Range("A:A"), 0))
End Sub
It in fact carries on and in total produces a whole bunch of vaules of various datatypes based on the users input.
So the user choses from a few check boxes, list boxes, fills in some text boxes and hits a submit button and this sub populates a number of varibles from that, that are then uterlised by other funcation and sub in the application.
Now I could make all the varibles Global and access them in that fassion. But I was hoping for something more like what I have seen with c# and VB.net
where you can get the value by using
sub.varible name
example for the code above.
Sub Main()
x = Varib.Device_
msgbox(x)
end sub
is there a simmular way to do this in VBA?
Cheers
aaron
What you're asking cannot be done. The solution is not to make your variables global either (generally a bad idea, with some exceptions, this case not being one of them).
One possibility is to create a user-defined type:
Type Varib
Device_ As String
Model_ As String
Security_ As String
Category_ As String
End Type
and a sub to populate it from your sheet:
Sub LoadVaribFromSheet(v As Varib)
With v
.Device_ = Sheet1.DeviceType_.Text
.Model_ = Sheet1.Model_.Text
.Security_ = Sheet1.SecurityGroup_.Text
.Category_ = _
Application.Index(Worksheets("Temp_for_varible_lists").Range("b:b"), _
Application.Match(x, _
Worksheets("Temp_for_varible_lists").Range("A:A"), 0))
End With
End Sub
You can then use this as follows:
Sub Main()
Dim myVarib As Varib
LoadVaribFromSheet myVarib
' Now do stuff with myVarib ...
MsgBox myVarib.Device_
End Sub
you can use encapsulation for this
Private value As String
Private value1 As String
Public Function setValue(val As String)
value = val
End Function
Public Function setValue1(val As String)
value1 = val
End Function
Public Function getValue() As String
getValue = value
End Function
Public Function getValue1() As String
getValue1 = value1
End Function
-------------------------------------------------------------------------
Sub test()
MsgBox getValue & vbCrLf & getValue1
setValue "myValue"
setValue1 "myValue1"
MsgBox getValue & vbCrLf & getValue1
End Sub