I have following json data:
{
"cgFinishing": {
"a3colorfn": [{
"type": "Cacah",
"kode": "CCH"
},
{
"type": "Cutting",
"kode": "CUT"
}
]
}
}
And my JSON Class:
Public Class A3colorfn
Public Property type As String
Public Property kode As String
End Class
Public Class CgFinishing
Public Property a3colorfn As A3colorfn()
End Class
Public Class CGSave
Public Property cgFinishing As CgFinishing
End Class
I want to write a method in VB.NET that pull values from this JSON array using JSON.NET. This code works for me:
Public Sub fillCBfromJson(ByVal cb As ComboBox, json As Object, Optional ByVal value As String = "", Optional display As String = "")
....
End Sub
But I'd like to replace json As Object with something that are more specific, because I'd like to retrieve the count of items in the array (something like Count or GetLength, I cannot expose those property with Object type)
For your reference this code works for me...
Dim count As Integer = jsonObj.cgFinishing.a3colorfn.GetLength(0)
But I have no idea to turn it as a method.
Any help is appreciated.
More code listing:
Private Sub PublishDigital_Load(sender As Object, e As System.EventArgs) Handles MyBase.Load
jsonPath = Application.StartupPath + "\Addons\CG_Tools\cgSave.json"
jsonObj = JsonConvert.DeserializeObject(Of CGSave)(File.ReadAllText(jsonPath))
initfinishingA3()
End Sub
Public Sub initfinishingA3() 'I want to make this as a method, so I'll only need to input the Array object as argument.
Dim cbdata As Object = jsonObj.cgFinishing.a3colorfn '<- I want to put this line as argument instead
Dim count As Integer = jsonObj.cgFinishing.a3colorfn.GetLength(0)
Dim myCb As New List(Of CheckBox)
For Each cur In cbdata
Dim cb = New CheckBox()
tb_finishinga3.Controls.Add(cb)
Dim txt As JObject = JsonConvert.DeserializeObject(Of JObject)(JsonConvert.SerializeObject(cur))
...
cb.Text = txt("type")
...
Next
End Sub
Following method I wrote does not work..
Public Sub fillTabwithCB(ByVal cbdata As JArray, XOffset As Integer, YOffset As Integer, maxRow As Integer)
Dim count As Integer = cbdata.Count
Dim loopIndex As Integer
Dim i As Integer = 0
Dim myCb As New List(Of CheckBox)
For Each cur In cbdata
Dim cb = New CheckBox()
tb_finishinga3.Controls.Add(cb)
Dim txt As JObject = JsonConvert.DeserializeObject(Of JObject)(JsonConvert.SerializeObject(cur))
.........
cb.Text = txt("type")
..........
Next
End Sub
Then I tried it in this line...
fillTabwithCB(jsonObj.cgFinishing.a3colorfn, 7, 7, 5)
It generates following error:
Value of type '1-dimensional array of
CG_FileManagement.A3colorfn' cannot be converted to
'Newtonsoft.Json.Linq.JArray'.
I need some help learning how to handle rolling up data by hierarchy groupings in VBA (PivotTables and even tables are not going to be sufficient due to "end-user" limitations).
I have granular data that with three levels of groupings: Parent, Child, Grain. A Parent may have more than 1 Child; and each Child may have more than 1 Grain. I need to take the universe of granular data and perform some calculations and then produce reports a the Parent and Child levels. For illustrative purposes, below are hypothetical structure/layout of source and desired outputs.
I've explored using Dictionaries and Collections, but neither seems to have the ability to restrict to unique/distinct relationships. For example, Dictionary will restrict to distinct Keys but will allow repetitive string values.
For example: Plants: Edible_Or_Not / Classification / Type / item
Edible / Fruit / Apple / Granny Smith
Edible / Fruit / Apple / Red Delicious
Edible / Vegetable / Asparagus / Asparagus
Nonedible / Tree / Maple / Red
Summaries:
1) Edible composed of Fruit and Vegetable
2) Fruit composed of Apple
3) Apple composed of Granny Smith and Red Delicious.
Below are the layouts more accurately representing my data.
Source:|||||
Parent Category Label|Child Category Label|Granular Label|DataPoint1|DataPoint2…|DataPoint3
---|---|---|---|---|---|
String A|String z|string z.g1.g2.g3|5|FALSE|1/1/1960
String A|String y|String y.g1.g2.g3|0|TRUE|1/2/1970
String B|String w|String w.g1.g2.g3|0|TRUE|9/5/1980
String C|String m|String m.g1.g2.g3|100|TRUE|1/1/1949
String C|String m|String m.g1a.g2.g3|2|FALSE|2/14/2008
String C|String n|String n.g1.g2.g3|2|TRUE|1/1/1950
String C|String o|String o.g1.g2.g3|0|FALSE|1/1/1905
String C|String o|String o.g1a.g2a.g3|0|FALSE|3/1/1977
String C|String p|String p.g1.g2.g3|1|FALSE|4/1/2000
Rollup Need Example #1||||
Parent|Distinct Children Count|Child1|Child 2|….Child(# - last)
---|---|---|---|---|
String A|2|String Z|String Y||
String B|1|String w|||
String C|4|String m|String n|...String p|
Rollup Need Example #2||||
Parent|Calculated Value ->|Sum DataPoint1 if and only if: (DataPoint 2 = "T" OR (inclusive) DataPoint1 <>0 )AND where DataPoint3 >=1/1/1950
---|---|---|---|
A|5||||
B|0||||
C|5||||
I'm going to assume you have three ListObjects on three sheets in an Excel Workbook.
Sheet1 (tblParent)
Item
A
B
C
Sheet2 (tblChild)
Item Parent
z A
y A
w B
m C
n C
o C
p C
Sheet3 (tblGrain)
Grain Parent Data1 Data2 Data3
y.g1.g2.g3 y 0 TRUE 1/2/1970
w.g1.g2.g3 w 0 TRUE 9/5/1980
m.g1.g2.g3 m 100 TRUE 1/1/1949
n.g1.g2.g3 n 2 TRUE 1/1/1950
I would create six class modules named CParent, CParents, CChild, CChildren, CGrain, CGrains.
CParents
Private mcolParents As Collection
Private Sub Class_Initialize()
Set mcolParents = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolParents = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolParents.[_NewEnum]
End Property
Public Sub Add(clsParent As CParent)
If clsParent.ParentID = 0 Then
clsParent.ParentID = Me.Count + 1
End If
mcolParents.Add clsParent, CStr(clsParent.ParentID)
End Sub
Public Property Get Parent(vItem As Variant) As CParent
Set Parent = mcolParents.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolParents.Count
End Property
Public Sub FillFromRange(ByRef rParents As Range, ByRef rChildren As Range, ByRef rGrains As Range)
Dim vaParents As Variant
Dim i As Long
Dim clsParent As CParent
vaParents = rParents.Value
For i = LBound(vaParents, 1) To UBound(vaParents, 1)
Set clsParent = New CParent
With clsParent
.Name_ = vaParents(i, 1)
End With
Me.Add clsParent
clsParent.Children.FillFromRange rChildren, clsParent.Name_, rGrains
Next i
End Sub
CParent
Private mlParentID As Long
Private msName_ As String
Private mclsChildren As CChildren
Public Property Set Children(ByVal clsChildren As CChildren): Set mclsChildren = clsChildren: End Property
Public Property Get Children() As CChildren: Set Children = mclsChildren: End Property
Public Property Let ParentID(ByVal lParentID As Long): mlParentID = lParentID: End Property
Public Property Get ParentID() As Long: ParentID = mlParentID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsChildren = New CChildren
End Sub
Private Sub Class_Terminate()
Set mclsChildren = Nothing
End Sub
CChildren
Private mcolChildren As Collection
Private Sub Class_Initialize()
Set mcolChildren = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolChildren = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolChildren.[_NewEnum]
End Property
Public Sub Add(clsChild As CChild)
If clsChild.ChildID = 0 Then
clsChild.ChildID = Me.Count + 1
End If
mcolChildren.Add clsChild, CStr(clsChild.ChildID)
End Sub
Public Property Get Child(vItem As Variant) As CChild
Set Child = mcolChildren.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolChildren.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sParentName As String, ByRef rGrains As Range)
Dim vaValues As Variant
Dim i As Long
Dim clsChild As CChild
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sParentName Then
Set clsChild = New CChild
With clsChild
.Name_ = vaValues(i, 1)
End With
Me.Add clsChild
clsChild.Grains.FillFromRange rGrains, clsChild.Name_
End If
Next i
End Sub
CChild
Private mlChildID As Long
Private msName_ As String
Private mclsGrains As CGrains
Public Property Set Grains(ByVal clsGrains As CGrains): Set mclsGrains = clsGrains: End Property
Public Property Get Grains() As CGrains: Set Grains = mclsGrains: End Property
Public Property Let ChildID(ByVal lChildID As Long): mlChildID = lChildID: End Property
Public Property Get ChildID() As Long: ChildID = mlChildID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsGrains = New CGrains
End Sub
Private Sub Class_Terminate()
Set mclsGrains = Nothing
End Sub
CGrains
Private mcolGrains As Collection
Private Sub Class_Initialize()
Set mcolGrains = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolGrains = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolGrains.[_NewEnum]
End Property
Public Sub Add(clsGrain As CGrain)
If clsGrain.GrainID = 0 Then
clsGrain.GrainID = Me.Count + 1
End If
mcolGrains.Add clsGrain, CStr(clsGrain.GrainID)
End Sub
Public Property Get Grain(vItem As Variant) As CGrain
Set Grain = mcolGrains.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolGrains.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sChildName As String)
Dim vaValues As Variant
Dim i As Long
Dim clsGrain As CGrain
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sChildName Then
Set clsGrain = New CGrain
With clsGrain
.Data1 = vaValues(i, 3)
.Data2 = vaValues(i, 4)
.Data3 = vaValues(i, 5)
End With
Me.Add clsGrain
End If
Next i
End Sub
CGrain
Private mlGrainID As Long
Private mlData1 As Long
Private mbData2 As Boolean
Private mdtData3 As Date
Public Property Let GrainID(ByVal lGrainID As Long): mlGrainID = lGrainID: End Property
Public Property Get GrainID() As Long: GrainID = mlGrainID: End Property
Public Property Let Data1(ByVal lData1 As Long): mlData1 = lData1: End Property
Public Property Get Data1() As Long: Data1 = mlData1: End Property
Public Property Let Data2(ByVal bData2 As Boolean): mbData2 = bData2: End Property
Public Property Get Data2() As Boolean: Data2 = mbData2: End Property
Public Property Let Data3(ByVal dtData3 As Date): mdtData3 = dtData3: End Property
Public Property Get Data3() As Date: Data3 = mdtData3: End Property
All this has done so far is to create three objects, establish relationships between them, and provide a way to fill them with data from an Excel range.
The relationships are established in the single object classes (not the plural ones). The CParent class has a property that holds a CChildren collection class. All of the children for that parent are stored in that class. The CChildren class holds a bunch of CChild objects. Each CChild object has a property CGrains that holds all the grains for that child. This is a lot of setup, but the payoff is coming.
Next, in a standard module, I want to create the procedure that fills the classes.
Public gclsParents As CParents
Public Sub Initialize()
Set gclsParents = New CParents
gclsParents.FillFromRange Sheet1.ListObjects(1).DataBodyRange, Sheet2.ListObjects(1).DataBodyRange, Sheet3.ListObjects(1).DataBodyRange
End Sub
I create a Public variable for the top collection class so it doesn't go out of scope. In Intialize, I instantiate the top collection class variable and call the FillFromRange method. I pass it my three Excel tables and the code fills in the all the classes.
Now lets say you wanted to create a procedure that listed all parents, a count of their children, and a list of their children.
Public Sub ListChildren()
Dim sh As Worksheet
Dim vaWrite As Variant
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
vaWrite = gclsParents.ChildListToRange
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
My CParents instance (held in gclsParents) returns an array that is dumped to a new sheet. The output looks like
A 2 z,y
B 1 w
C 4 m,n,o,p
Now you have to create the ChildListToRange method. Add this to the CParents class
Public Property Get ChildListToRange() As Variant
Dim aReturn() As Variant
Dim clsParent As CParent
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 3)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.Children.Count
aReturn(lCnt, 3) = clsParent.ChildListDelimited(",")
Next clsParent
ChildListToRange = aReturn
End Property
The first two columns in the array are already defined, but we need to create a ChildListDelimited property in the CParent class. Add this to CParent
Public Property Get ChildListDelimited(ByVal sDelim As String) As String
Dim clsChild As CChild
Dim aReturn() As String
Dim lCnt As Long
ReDim aReturn(1 To Me.Children.Count)
For Each clsChild In Me.Children
lCnt = lCnt + 1
aReturn(lCnt) = clsChild.Name_
Next clsChild
ChildListDelimited = Join(aReturn, sDelim)
End Property
You supply a delimiter, this property returns a string of all the children separated by that delimiter.
And that's it. Your first report is done. Next, you want to create a report that sums up Data1 with certain criteria. Create this procedure in a standard module
Public Sub SummarizeValues()
Dim sh As Worksheet
Dim vaWrite As Variant
Dim clsToSum As CParents
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
Set clsToSum = gclsParents.FilterByData2(True).FilterByData3(DateSerial(1950, 1, 1), ">=")
vaWrite = clsToSum.SummarizeGrainValues
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
That looks a lot like the first procedure except that the CParents property that returns the array (to be written to a worksheet) is different. Also, we do some filtering. In the first procedure, we wanted every parent. Now we only want parents that meet certain criteria. For that, create a couple of FilterBy properties. In CParents add
Public Property Get FilterByData2(ByVal lData As Long) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData2(lData)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData2 = clsReturn
End Property
This is a common filtering property. It takes a big CParents instance (gclsParents in this case) and returns a smaller one. If it finds children that meet the criteria, it adds the parent to the return class. Otherwise it doesn't. But you'll need to pass that criteria down to the children. Add this to the CChildren class
Public Property Get FilterByData2(ByVal lData As Long) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData2(lData)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData2 = clsReturn
End Property
And add this to the CGrains class
Public Property Get FilterByData2(ByVal lData As Long) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Set clsReturn = New CGrains
For Each clsGrain In Me
If clsGrain.Data2 = lData Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData2 = clsReturn
End Property
All that returns a CParents instance with the only the parents that eventually have a grain with true in Data2.
From that already smaller CParents instance, we tack on another filter. Add this to CParents
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData3(dtData, sComp)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData3 = clsReturn
End Property
Because this filter uses an inequality, it gets a little more complicated as we'll see in a minute. For now, add this to CChildren
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData3(dtData, sComp)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData3 = clsReturn
End Property
And add this to CGrains
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Dim bAdd As Boolean
Set clsReturn = New CGrains
For Each clsGrain In Me
Select Case sComp
Case ">="
bAdd = clsGrain.Data3 >= dtData
Case ">"
bAdd = clsGrain.Data3 > dtData
Case "<"
bAdd = clsGrain.Data3 < dtData
Case "<="
bAdd = clsGrain.Data3 <= dtData
Case Else
bAdd = clsGrain.Data3 = dtData
End Select
If bAdd Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData3 = clsReturn
End Property
You can see in CGrains that I have to use a Select Case to figure out what inequality you want. But other that wrinkle, it does the same thing as the first filter.
Now you have a variable clsToSum that is a CParents instance that only contains parents you want. You've already done the filtering, now all you have to do it sum stuff up. Add this to CParents
Public Property Get SummarizeGrainValues() As Variant
Dim clsParent As CParent
Dim aReturn() As Variant
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 2)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.SumData1
Next clsParent
SummarizeGrainValues = aReturn
End Property
Now you have to add SumData1 to CParent
Public Property Get SumData1() As Long
Dim lReturn As Long
Dim clsChild As CChild
Dim clsGrain As CGrain
For Each clsChild In Me.Children
For Each clsGrain In clsChild.Grains
lReturn = lReturn + clsGrain.Data1
Next clsGrain
Next clsChild
SumData1 = lReturn
End Property
That loops through all the grains in all the children and adds them up. The output looks like
A 0
B 0
C 2
Now that the infrastructure is done, you can create any manner of report you want. You simply have to set up whatever filters you need and any aggregation properties you want to report.
I probably should have said this at the top, but if you put these three tables in a proper relational database, you can accomplish all this with two fairly short SQL statements.
If you want to see it all together in a workbook, download this http://dailydoseofexcel.com/excel/ClassParentChildGrains.zip
Custom classes would allow you to create a hierarchy, the example class below is to get you started.
A parent object can place child objects within the container collection and then perform rollup calculations aggregating all objects within the collection.
Assuming you place child objects within the collection you could place grain objects within their container also and create a hierarchy as suits.
Private pContainer As New Collection
Private pTitle As String
Private pValueToSum As Double
Public Property Get Container() As Collection
Set Container = pContainer
End Property
Public Property Let Container(value As Collection)
Set pContainer = value
End Property
Public Property Get GetTotals() As Double
Dim dbl As Double
Dim var As Variant
For Each var In Me.Container
dbl = dbl + var.ValueToSum
Next var
GetTotals = dbl
End Property
I have several classes containing details about an onsite switchboard. I am using a Userform to store data in the variables declared in each class. I am struggling to store the data in any of my arrays. Am I going the right way about declaring these variables? Here's an example of one of my classes:
Dim pEquipID(3) As String
Dim pIr(3) As Integer
Dim pIm(3) As Integer
Dim pTripCurrent(3) As Integer
Dim pTripTime(3) As Integer
Dim pIsc(3) As Integer
Public Property Let EquipID(index As Integer, value As String)
pEquipID(index) = value
End Property
Public Property Let Ir(index As Integer, value As Integer)
pIr(index) = value
End Property
Public Property Let Im(index As Integer, value As Integer)
pIm(index) = value
End Property
Public Property Let TripCurrent(index As Integer, value As Integer)
pTripCurrent(index) = value
End Property
Public Property Let TripTime(index As Integer, value As Integer)
pTripTime(index) = value
End Property
Public Property Let Isc(index As Integer, value As Integer)
pIsc(index) = value
End Property
Public Property Get EquipID(index As Integer) As String
EquipID(index) = pEquipID(index)
End Property
Public Property Get Ir(index As Integer) As Integer
Ir(index) = pIr(index)
End Property
Public Property Get Im(index As Integer) As Integer
Im(index) = pIm(index)
End Property
Public Property Get TripCurrent(index As Integer) As Integer
TripCurrent(index) = pTripCurrent(index)
End Property
Public Property Get TripTime(index As Integer) As Integer
TripTime(index) = pTripTime(index)
End Property
Public Property Get Isc(index As Integer) As Integer
Isc(index) = pIsc(index)
End Property
And this is how I am storing the data:
Private Sub Enter1_Click()
'create class variables
Dim Transformer1 As cTransformer
Set Transformer1 = New cTransformer
Dim Fuse1 As cFuse
Set Fuse1 = New cFuse
Dim CircuitBreaker1 As cCircuitBreaker
Set CircuitBreaker1 = New cCircuitBreaker
Dim Pump1 As cPump
Set Pump1 = New cPump
Dim Cable1 As cCable
Set Cable1 = New cCable
'store circuit breaker entries
CircuitBreaker1.EquipID(0) = CB1ID1.value
CircuitBreaker1.EquipID(1) = CB2ID1.value
CircuitBreaker1.Ir(0) = Cb1Ir1.value
CircuitBreaker1.Ir(1) = CB2Ir1.value
CircuitBreaker1.Im(0) = CB1Im1.value
CircuitBreaker1.Im(1) = CB2Im1.value
CircuitBreaker1.Isc(0) = CB1Isc1.value
CircuitBreaker1.Isc(1) = CB2Isc1.value
CircuitBreaker1.TripCurrent(0) = CB1trip1.value
CircuitBreaker1.TripCurrent(1) = CB2trip1.value
CircuitBreaker1.TripTime(0) = CB1time1.value
CircuitBreaker1.TripTime(1) = CB2time1.value
When I debug.print the CircuitBreaker array the terminal prints blank values. I use a loop like this to print each array:
Dim count As integer
For count = 0 To 1 Step 1
Debug.Print CircuitBreaker1.EquipID(count)
Next count
Note that this print statement is inside Enter1_click()
Your Property Get is incorrect. Instead of:
Public Property Get EquipID(index As Integer) As String
EquipID(index) = pEquipID(index)
End Property
... it should be:
Public Property Get EquipID(index As Integer) As String
EquipID = pEquipID(index)
End Property
I'd like to use classes instead of structures in my VBA program, but could not figure it out. Below is an example of what I'm doing, and would be grateful for any advice. Maybe classes are not good for this type of thing, because it did not seem very intuitive to me, I don't know.
Option Explicit
Public Type xYear
month(1 To 12) As Double ' Index is the month
End Type
Public Type Company
Name As String
City As String
Sales(2010 To 2020) As xYear ' Index is the year
End Type
Public SuperData(1 To 50) As Company ' An array of companies with monthly sales
Sub Test_Table()
Dim Company1_Name As String
Dim Company1_City As String
Dim Company1_2011_Sales(1 To 12) As Double
Dim Company1_2012_Sales(1 To 12) As Double
Dim Toledo_Sales_Jul_2012 As Double
' Test Data
Company1_Name = "ABC"
Company1_City = "Toledo"
Company1_2011_Sales(7) = 1000
Company1_2012_Sales(7) = 2000
' Copy test data into Structure
SuperData(1).Name = Company1_Name
SuperData(1).City = Company1_City
SuperData(1).Sales(2011).month(7) = Company1_2011_Sales(1) ' Jul 2011 sales
SuperData(1).Sales(2012).month(7) = Company1_2012_Sales(7) ' Jul 2012 sales
' Query the structure
Toledo_Sales_Jul_2012 = City_Sales("Toledo", 7, 2012)
End Sub
Public Function City_Sales(ByRef City As String, ByRef m As Double, ByRef y As Double) As Double
Dim c As Double
For c = LBound(SuperData) To UBound(SuperData)
If City = SuperData(c).City Then
City_Sales = City_Sales + SuperData(c).Sales(y).month(m)
End If
Next
End Function
I would do this with four classes: CCompany and CSale and collection classes for both.
CCompany:
Private mlCompanyID As Long
Private msCompanyName As String
Private msCity As String
Private mclsSales As CSales
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, Source As Any, ByVal bytes As Long)
Public Property Set Sales(ByVal clsSales As CSales): Set mclsSales = clsSales: End Property
Public Property Get Sales() As CSales: Set Sales = mclsSales: End Property
Public Property Let CompanyID(ByVal lCompanyID As Long): mlCompanyID = lCompanyID: End Property
Public Property Get CompanyID() As Long: CompanyID = mlCompanyID: End Property
Public Property Let CompanyName(ByVal sCompanyName As String): msCompanyName = sCompanyName: End Property
Public Property Get CompanyName() As String: CompanyName = msCompanyName: End Property
Public Property Let City(ByVal sCity As String): msCity = sCity: End Property
Public Property Get City() As String: City = msCity: End Property
Public Property Get Parent() As CCompanies: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CCompanies): mlParentPtr = ObjPtr(obj): End Property
Private Function ObjFromPtr(ByVal pObj As Long) As Object
Dim obj As Object
CopyMemory obj, pObj, 4
Set ObjFromPtr = obj
' manually destroy the temporary object variable
' (if you omit this step you'll get a GPF!)
CopyMemory obj, 0&, 4
End Function
Private Sub Class_Initialize()
Set mclsSales = New CSales
End Sub
Private Sub Class_Terminate()
Set mclsSales = Nothing
End Sub
CCompanies:
Private mcolCompanies As Collection
Private Sub Class_Initialize()
Set mcolCompanies = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolCompanies = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolCompanies.[_NewEnum]
End Property
Public Sub Add(clsCompany As CCompany)
If clsCompany.CompanyID = 0 Then
clsCompany.CompanyID = Me.Count + 1
End If
Set clsCompany.Parent = Me
mcolCompanies.Add clsCompany, CStr(clsCompany.CompanyID)
End Sub
Public Property Get Company(vItem As Variant) As CCompany
Set Company = mcolCompanies.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolCompanies.Count
End Property
CSale:
Private mlSaleID As Long
Private mdAmount As Double
Private mlYear As Long
Private mlMonth As Long
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, Source As Any, ByVal bytes As Long)
Public Property Let SaleID(ByVal lSaleID As Long): mlSaleID = lSaleID: End Property
Public Property Get SaleID() As Long: SaleID = mlSaleID: End Property
Public Property Let Amount(ByVal dAmount As Double): mdAmount = dAmount: End Property
Public Property Get Amount() As Double: Amount = mdAmount: End Property
Public Property Let Year(ByVal lYear As Long): mlYear = lYear: End Property
Public Property Get Year() As Long: Year = mlYear: End Property
Public Property Let Month(ByVal lMonth As Long): mlMonth = lMonth: End Property
Public Property Get Month() As Long: Month = mlMonth: End Property
Public Property Get Parent() As CSales: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CSales): mlParentPtr = ObjPtr(obj): End Property
Private Function ObjFromPtr(ByVal pObj As Long) As Object
Dim obj As Object
CopyMemory obj, pObj, 4
Set ObjFromPtr = obj
' manually destroy the temporary object variable
' (if you omit this step you'll get a GPF!)
CopyMemory obj, 0&, 4
End Function
CSales:
Private mcolSales As Collection
Private Sub Class_Initialize()
Set mcolSales = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolSales = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolSales.[_NewEnum]
End Property
Public Sub Add(clsSale As CSale)
If clsSale.SaleID = 0 Then
clsSale.SaleID = Me.Count + 1
End If
Set clsSale.Parent = Me
mcolSales.Add clsSale, CStr(clsSale.SaleID)
End Sub
Public Property Get Sale(vItem As Variant) As CSale
Set Sale = mcolSales.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolSales.Count
End Property
Public Sub AddSale(ByVal dAmount As Double, ByVal lYear As Long, ByVal lMonth As Long)
Dim clsSale As CSale
Set clsSale = New CSale
With clsSale
.Amount = dAmount
.Year = lYear
.Month = lMonth
End With
Me.Add clsSale
End Sub
Then in a standard module.
Sub Test_Class()
Dim clsCompanies As CCompanies
Dim clsCompany As CCompany
Dim clsSale As CSale
Set clsCompanies = New CCompanies
Set clsCompany = New CCompany
clsCompany.CompanyName = "ABC"
clsCompany.City = "Toledo"
'Verbose way to add a sale
Set clsSale = New CSale
clsSale.Amount = 1000
clsSale.Year = 2011
clsSale.Month = 7
clsCompany.Sales.Add clsSale
'Quickway to add a sale
clsCompany.Sales.AddSale 2000, 2012, 7
clsCompanies.Add clsCompany
For Each clsCompany In clsCompanies
For Each clsSale In clsCompany.Sales
Debug.Print clsCompany.CompanyName, clsCompany.City, clsSale.Amount, clsSale.Year, clsSale.Month
Next clsSale
Next clsCompany
End Sub
This uses some undocumented features, such as to be able to use For Each on a custom class. Here are a couple of references for you.
http://dailydoseofexcel.com/archives/2010/07/09/creating-a-parent-class/
http://www.cpearson.com/excel/classes.aspx
I have a class where one of the member variables is an array. I am trying to assign an array to the object but keep getting the 'Can't assign array' compile error. Also I was curious as how to get UBound of the array in object. UBound(obj.array) doesn't compile. I am using excel 07 vba.
'Test routine that keeps failing
Sub test()
Dim Arr(2) As String
Arr(0) = ""
Arr(1) = "Pizza"
Arr(2) = "Hoes"
Dim obj As Cats
Set obj = New Cats
obj.avry = Arr
obj.field = 4
MsgBox UBound(obj.ary)
End Sub
'Class declaration
Private pary() As String
Private pfield As Long
Public Property Get ary(ByVal index As Long) As String
Set ary = pary(index)
End Property
Public Property Let avry(Value() As String)
ReDim pary(UBound(Value)) As String
For i = LBound(Value) To UBound(Value)
pary(i) = Value(i)
Next i
End Property
Public Property Get field() As Long
field = pfield
End Property
Public Property Let field(Value As Long)
pfield = Value
End Property
Private Sub Class_Initialize()
pfield = 0
End Sub
This worked for me
Sub test()
Dim Arr(2) As String
Arr(0) = ""
Arr(1) = "Pizza"
Arr(2) = "Hoes"
Dim obj As Cats
Set obj = New Cats
obj.avry = Arr
obj.field = 4
MsgBox obj.ary(2)
End Sub
Public Property Get ary(ByVal index As Long) As String
ary = pary(index)
End Property
Public Property Let avry(vValue As Variant)
ReDim pary(UBound(vValue)) As String
Dim i As Long
For i = LBound(vValue) To UBound(vValue)
pary(i) = vValue(i)
Next i
End Property
Public Property Get field() As Long
field = pfield
End Property
Public Property Let field(Value As Long)
pfield = Value
End Property
Private Sub Class_Initialize()
pfield = 0
End Sub
As Tim said, you can pass the array as a variant. Your MsgBox is trying to find a UBound of a String data type, so that was a problem. Also, you weren't passing an argument to ary in the MsgBox. The ary property returns a String, but you were using the Set keyword, which was another problem.
There seems to be an issue with passing array parameters to class properties.
You can get around this by switching the Let parameter to a Variant:
Public Property Let avry(ByRef arrVal As Variant)
Dim i As Integer
If IsArray(arrVal) Then
ReDim pary(LBound(arrVal) To UBound(arrVal))
For i = LBound(arrVal) To UBound(arrVal)
pary(i) = arrVal(i)
Next i
End If
End Property