I am currently creating a Class Object for a VBA file, its objective is to act as a range dictionary that can be passed single cells. If this cell is contained in one of the ranges, it returns the value associated to the corresponding range key. The class name is "rangeDic".
It is in the making so its functionalities are not implemented yet. Here's the code:
Private zone() As String
Private bounds() As String
Private link As Dictionary
Const ContextId = 33
'Init zone
Private Sub Class_Initialize()
Set link = New Dictionary
ReDim zone(0)
ReDim bounds(0)
End Sub
'properties
Property Get linkDico() As Dictionary
Set linkDico = link
End Property
Property Set linkDico(d As Dictionary)
Set link = d
End Property
Property Get pZone() As String()
pZone = zone
End Property
Property Let pZone(a() As String)
Let zone = a
End Property
'methods
Public Sub findBounds()
Dim elmt As String
Dim i As Integer
Dim temp() As String
i = 1
For Each elmt In zone
ReDim Preserve bounds(i)
temp = Split(elmt, ":")
bounds(i - 1) = temp(0)
bounds(i) = temp(1)
i = i + 2
Next elmt
End Sub
I was trying to instanciate it in a test sub in order to debug mid conception. Here's the code:
Sub test()
Dim rd As rangeDic
Dim ran() As String
Dim tabs() As Variant
Dim i As Integer
i = 1
With ThisWorkbook.Worksheets("DataRanges")
While .Cells(i, 1).Value <> none
ReDim Preserve ran(i - 1)
ReDim Preserve tabs(i - 1)
ran(i - 1) = .Cells(i, 1).Value
tabs(i - 1) = .Cells(i, 3).Value
i = i + 1
Wend
End With
Set rd = createRangeDic(ran, tabs)
End Sub
Public Function createRangeDic(zones() As String, vals() As Variant) As rangeDic
Dim obje As Object
Dim zonesL As Integer
Dim valsL As Integer
Dim i As Integer
zonesL = UBound(zones) - LBound(zones)
valsL = UBound(vals) - LBound(vals)
If zonesL <> valsL Then
Err.Raise vbObjectError + 5, "", "The key and value arrays are not the same length.", "", ContextId
End If
Set obje = New rangeDic
obje.pZone = zones()
For i = 0 To 5
obje.linkDico.add zones(i), vals(i)
Next i
Set createRangeDic = obje
End Function
Take a look at line 2 of Public Function createRangeDic. I have to declare my object as "Object", if I try declaring it as "rangeDic", Excel crashes at line obje.pZone = zones(). Upon looking in the Windows Event Log, I can see a "Error 1000" type of application unknown error resulting in the crash, with "VB7.DLL" being the faulty package.
Why so ? Am I doing something wrong ?
Thanks for your help
Edit: I work under Excel 2016
It looks like this is a bug. My Excel does not crash but I get an "Internal Error".
Let's clarify a few things first, since you're coming from a Java background.
Arrays can only be passed by reference
In VBA an array can only be passed by reference to another method (unless you wrap it in a Variant). So, this declaration:
Property Let pZone(a() As String) 'Implicit declaration
is the equivalent of this:
Property Let pZone(ByRef a() As String) 'Explicit declaration
and of course, this:
Public Function createRangeDic(zones() As String, vals() As Variant) As rangeDic
is the equivalent of this:
Public Function createRangeDic(ByRef zones() As String, ByRef vals() As Variant) As rangeDic
If you try to declare a method parameter like this: ByVal a() As String you will simply get a compile error.
Arrays are copied when assigned
Assuming two arrays called a and b, when doing something like a = b a copy of the b array is assigned to a. Let's test this. In a standard module drop this code:
Option Explicit
Sub ArrCopy()
Dim a() As String
Dim b() As String
ReDim b(0 To 0)
b(0) = 1
a = b
a(0) = 2
Debug.Print "a(0) = " & a(0)
Debug.Print "b(0) = " & b(0)
End Sub
After running ArrCopy my immediate window looks like this:
As shown, the contents of array b are not affected when changing array a.
A property Let always receives it's parameters ByVal regardless of whether you specify ByRef
Let's test this. Create a class called Class1 and add this code:
Option Explicit
Public Property Let SArray(ByRef arr() As String)
arr(0) = 1
End Property
Public Function SArray2(ByRef arr() As String)
arr(0) = 2
End Function
Now create a standard module and add this code:
Option Explicit
Sub Test()
Dim c As New Class1
Dim arr() As String: ReDim arr(0 To 0)
arr(0) = 0
Debug.Print arr(0) & " - value before passing to Let Property"
c.SArray = arr
Debug.Print arr(0) & " - value after passing to Let Property"
arr(0) = 1
Debug.Print arr(0) & " - value before passing to Function"
c.SArray2 arr
Debug.Print arr(0) & " - value after passing to Function"
End Sub
After running Test, my immediate window looks like this:
So, this simple test proves that the Property Let does a copy of the array even though arrays can only be passed ByRef.
The bug
Your original ran variable (Sub test) is passed ByRef to createRangeDic under a new name zones which is then passed ByRef again to pZone (the Let property). Under normal circumstances there should be no issue with passing an array ByRef as many times as you want but here it seems it is an issue because the Property Let is trying to make a copy.
Interestingly if we replace this (inside createRangeDic):
obje.pZone = zones()
with this:
Dim x() As String
x = zones
obje.pZone = x
the code runs with no issue even if obje is declared As rangeDic. This works because the x array is a copy of the zones array.
It looks that the Property Let cannot make a copy of an array that has been passed ByRef multiple times but it works perfectly fine if it was passed ByRef just once. Maybe because of the way stack frames are added in the call stack, there is a memory access issue but difficult to say. Regardless what the problem is, this seems to be a bug.
Unrelated to the question but I must add a few things:
Using ReDim Preserve in a loop is a bad idea because each time a new memory is allocated for a new (larger) array and each element is copied from the old array to the new array. This is very slow. Instead use a Collection as
#DanielDuĊĦek suggested in the comments or minimize the number of ReDim Preserve calls (for example if you know how many values you will have then just dimension the array once at the beginning).
Reading a Range cell by cell is super slow. Read the whole Range into an array by using the Range.Value or Range.Value2 property (I prefer the latter). Both methods returns an array as long as the range has more than 1 cell.
Never expose a private member object of a class if that object is responsible for the internal workings of the class. For example you should never expose the private collection inside a custom collection class because it breaks encapsulation. In your case the linkDico exposes the internal dictionary which can the be modified from outside the main class instance. Maybe it does not break anything in your particular example but just worth mentioning. On the other hand Property Get pZone() As String() is safe as this returns a copy of the internal array.
Add Option Explicit to the top of all your modules/classes to make sure you enforce proper variable declaration. Your code failed to compile for me because none does not exist in VBA unless you have it somewhere else in your project. There were a few other issues that I found once I turned the option on.
Related
I have a Client class. Inside that class there is an array losses. First I create and populate with clients a clientsColl array. Then for each client in that array I populate its losses array.
Then I try to print into debug a first element of losses for each client. However, it doesnt work and Property let procedure not defined and property get procedure did not return an object error appears.
And the same time if I just try to display a first element of losses for the first client, without any cycle, it works fine:
Dim clientsColl() As Client
clientsColl = getClients(dataWorkbook)
Dim clientCopy As Variant
Debug.Print "first: " & clientsColl(1).getLosses(1) 'works fine
For Each clientCopy In clientsColl
Debug.Print "in for each: " & clientCopy.getLosses(1) 'error here
Next
In Client class:
Public Property Get getLosses()
getLosses = losses
End Property
Private losses() As Double
How the losses array is populated:
Public Sub calculateFinancialResult()
ReDim losses(1 To simulationCount)
ReDim profits(1 To simulationCount)
Dim i As Long
For i = 1 To simulationCount
If outcomes(i) = 1 Then
losses(i) = totalLoss
...
Else
...
End If
Next
End Sub
Why does this happen and how to fix it?
EDIT: more of the main sub:
For Each clientCopy In clientsColl
clientCopy.setSimulationCount = globals("SIMULATION_COUNT")
...
clientCopy.calculateFinancialResult
...
Next
EDIT:
At the same time a simple for cycle works fine:
Debug.Print "first: " & clientsColl(1).getLosses(1)
For tempCount = LBound(clientsColl) To UBound(clientsColl)
Debug.Print "in for each: " & _
clientsColl(tempCount).getLosses(1)
Next
To conclude what was said in comments:
Your problem (error 451) often occures when you trying to compound properties.
To represent this case we can use any structure of any object with properties.
Let's emulate it with array of collections:
Option Explicit
Sub Test()
Dim Arr As Variant
Dim Col As Collection
Dim i As Long
Dim j As Long
ReDim Arr(1 To 10)
For i = 1 To 10
Set Col = New Collection
For j = 1 To 10
Call Col.Add(j)
Next
Set Arr(i) = Col
Next
On Error Resume Next
Debug.Print Arr(1).Item(1)
Debug.Print Arr(1).Item()(1)
On Error GoTo 0
End Sub
Your problem stems from the fact that you're treating your properties as attributes. On not-so-compounded (or when your array is declared explicitly as array of class instances) level it works due to early binding. But when things start to get more complex - it's fail, since your property just another function.
Hence, to achieve what you want, you should call it explicitly with another pair of parentheses.
Your getLosses property doesn't take an argument so your syntax is actually wrong, even though VBA can cope with it when early bound. You should be using:
Debug.Print "first: " & clientsColl(1).getLosses()(1) 'works fine
For Each clientCopy In clientsColl
Debug.Print "in for each: " & clientCopy.getLosses()(1) 'error here
Next
I also meet this problem when I create my customize array class using compound properties.
I solved it by adding class statment for return value in Property Get code. Just as what #Rory said.
You could try Public Property Get getLosses() As Double in the Client class.
I have a class that holds data in separate attributes (I chose this design instead of an array or scripting.dictionary because I will be using these data for the construction of a decision tree and I want to make use of IntelliType while I construct it.).
The data are loaded from an excel spreadsheet in the form of floats, so I am storing them in a long datatype, but from time to time it happens so that a value is missing and is replaced by an "NA" string.
I would like to create an error-handling routine, that, if a non-numeric value is encountered, would replace the content with a value -1.
I know I could do this with checking with IsNumeric() or error-handling, but I don't know how to make it work for every one of the many attributes the class holds and I don't really like the solution to write a specific error-handling code for every one of them (storing each of them in a separate attribute is not elegant as well, but I find this a price I am willing to pay for the advantage of shorter syntax in the decision tree).
Is there a way to pass a value to a variable, that just encountered a type-mismatch error, by the error-handling code independent of the variable name?
A simple example with several of the attributes:
Option Explicit
Dim B_LYM As Long
Dim B_mem As Long
Dim B_CXCR3 As Long
Dim B_CXCR4_MFI As Long
Public Sub SetData(data as Range)
On Error Goto err_handler
B_LYM = data.Cells(1, 1)
B_mem = data.Cells(1, 2)
B_CXCR3 = data.Cells(1, 3)
B_CXCR4_MFI = data.Cells(1, 4)
err_handler:
'I need something like this:
'if valuebeingstored = "NA" then targetvariable = -1
End Sub
It could be that some other approach could be better and I am gladly open to options, I only want to emphasize that I would really like make use of IntelliType when constructing the decision tree. I was considering using scripting.dictionary, but the syntax will bloat the code very quickly.
You said you have a Class and therefore could include the function to check the input and return -1 inside the class and use the Get and Let properties to call the function.
Here is an example class (named clsDataStuff) demonstrating this:
Option Explicit
Private c_B_LYM As Double
Private c_B_mem As Double
Private c_B_CXCR3 As Double
Private c_B_CXCR4_MFI As Double
Public Property Let B_LYM(varValue As Variant)
c_B_LYM = ParseDouble(varValue)
End Property
Public Property Get B_LYM()
B_LYM = c_B_LYM
End Property
Public Property Let B_mem(varValue As Variant)
c_B_mem = ParseDouble(varValue)
End Property
Public Property Get B_mem()
B_mem = c_B_mem
End Property
Public Property Let B_CXCR3(varValue As Variant)
c_B_CXCR3 = ParseDouble(varValue)
End Property
Public Property Get B_CXCR3()
B_CXCR3 = c_B_CXCR3
End Property
Public Property Let B_CXCR4_MFI(varValue As Variant)
c_B_CXCR4_MFI = ParseDouble(varValue)
End Property
Public Property Get B_CXCR4_MFI()
B_CXCR4_MFI = c_B_CXCR4_MFI
End Property
Private Function ParseDouble(varValue As Variant) As Double
If IsNumeric(varValue) Then
ParseDouble = CDbl(varValue)
Else
ParseDouble = -1
End If
End Function
Noting that:
the Let property expects a Variant because you say your input could be a number, or a string
the Get property returns Double as you said your inputs are floats so Double is better than Long
the ParseDouble function simply checks for a numeric input and returns -1 otherwise
Then, in your module code:
Option Explicit
Dim B_LYM As Long
Dim B_mem As Long
Dim B_CXCR3 As Long
Dim B_CXCR4_MFI As Long
Public Sub Test()
Dim objDataStuff As clsDataStuff
Set objDataStuff = New clsDataStuff
objDataStuff.B_LYM = 1 'data.Cells(1, 1)
objDataStuff.B_mem = 2 'data.Cells(1, 2)
objDataStuff.B_CXCR3 = "a" 'data.Cells(1, 3)
objDataStuff.B_CXCR4_MFI = True 'data.Cells(1, 4)
Debug.Print objDataStuff.B_LYM
Debug.Print objDataStuff.B_mem
Debug.Print objDataStuff.B_CXCR3
Debug.Print objDataStuff.B_CXCR4_MFI
End Sub
Returns an output of:
1
2
-1
-1
Intellisense is available and you get validation of the input:
Edit - regarding the comment on dynamically setting a target variable.
Your class can be:
Option Explicit
Public B_LYM As Double
Public B_mem As Double
Public B_CXCR3 As Double
Public B_CXCR4_MFI As Double
Public Sub SetVar(ByVal strVarName As String, ByVal varValue As Variant)
Dim dblValue As Double
Dim strToEval As String
If Not MemberExists(strVarName) Then Exit Sub
dblValue = ParseDouble(varValue) ' do the parse
CallByName Me, strVarName, VbLet, dblValue ' dynamically assign the value
End Sub
Private Function ParseDouble(varValue As Variant) As Double
If IsNumeric(varValue) Then
ParseDouble = CDbl(varValue)
Else
ParseDouble = -1
End If
End Function
Private Function MemberExists(strVarName) As Boolean
Dim blnTest As Boolean
Dim varValue As Variant
On Error GoTo ErrHandler
varValue = CallByName(Me, strVarName, VbGet)
blnTest = True
GoTo ExitFunction
ErrHandler:
blnTest = False
ExitFunction:
MemberExists = blnTest
End Function
Where:
All the variables are Public and you still get Intellisense but avoid all the repetitive Let and Get code
A single SetVar method uses CallByName to dynamically set a target variable
Two problems:
You need the clunky MemberExists function to prevent SetVar trying to assign a value to a member that does not exist - otherwise this generates an error (438) but perhaps this is something you need in your logic ?
You can still assign values to the target variable with e.g. objDataStuff.B_CXR3 = "foo" which alsos produces an error for anything other than a number.
The example code shows the problem below. But sticking with SetVar method will produce the same output as above.
Option Explicit
Dim B_LYM As Long
Dim B_mem As Long
Dim B_CXCR3 As Long
Dim B_CXCR4_MFI As Long
Public Sub Test()
Dim objDataStuff As clsDataStuff
Set objDataStuff = New clsDataStuff
objDataStuff.SetVar "B_LYM", 1
objDataStuff.SetVar "B_mem", 2
objDataStuff.SetVar "B_CXCR3", -1
objDataStuff.SetVar "B_CXCR4_MFI", True
objDataStuff.SetVar "foobar", 999
' working around SetVar here generates an error
objDataStuff.B_CXCR3 = "bad"
Debug.Print objDataStuff.B_LYM
Debug.Print objDataStuff.B_mem
Debug.Print objDataStuff.B_CXCR3
Debug.Print objDataStuff.B_CXCR4_MFI
End Sub
Is there anyway that I can put various classes into an array so that instead of hard-coding like:
set var1 = new cls1
set var2 = new cls2
we can do:
varArr = array ( var1, var2...)
clsArr = array (cls1, cls2...)
and now I just loop thru varArr and clsArr to set new class accordingly, like:
sub setNew(x as double)
set varArr(x) = new clsArr(x)
end sub
I did try but it didn't work, please help me out
Thank you very much !
Triet (mr)
I try, but my knowledge also limited.
First of all I do not think you can put class into an array. You can put objects. I also failed to use the array() function.
Please see how I proceeded with some demonstration:
This is the class module, containing a value, the property and a primitive print sub:
Private nr As Integer 'Use as identification
Sub cPrint()
MsgBox "Object ID: " & nr
End Sub
Property Let ID(v As Integer)
nr = v
End Property
In the module in the first cycle I create the object, put the ID value. In the second one all ID values are printed. I hope you can use it for your purposes.
Sub clsTest()
Dim varArr(1 To 5) As cls1
Dim i As Integer
For i = 1 To 5
Set varArr(i) = New cls1
varArr(i).ID = i
Next
For i = 1 To 5
varArr(i).cPrint
Next
End Sub
First of all I want so say sorry for not showing any code but right now I need some guidelines on how to take out a unique ID of a string.
So I have some problems of how to organize data. Lets say that the data is organized so that each dataID has their unique name. I collect the data into a array that holds it.
The problem I now have is that I want a easy way to search for these nameID. Imagine that the data is a lot bigger and contain more than a few hundred of different unique combinations of nameID's. Therefor I do not think searching for the id itself would be appropriate and I'm thinking of creating an hash that I could use an algorithm on to search the array. I want to do this because later on I will compare the names and add the values to the respective nameID. Keep in mind that the nameID will most of the time have the same structure but eventually a new name like total_air could be implemented and then I need to search in the array to get right value.
Updated:
Example of an code that collect the data from excel:
For Each targetSheet In wb.Worksheets
With targetSheet
'Populate the array
xData(0) = Application.Transpose(Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Value2)
cnt = UBound(xData(0))
End With
Call dData.init(cnt)
'Populate the objectarray
dData.setNameArray = xData(0)
Next targetSheet
Type object:
Private index As Integer
Private id As String
Private nameID() As Variant
Private data() As Variant
Private cnt As Integer
Public Sub init(value As Integer)
index = 0
cnt = value
id = ""
ReDim nameID(0 To cnt)
ReDim data(0 To cnt)
End Sub
Property Let setID(value As String)
id = value
End Property
Property Let setNameArray(value As Variant)
nameID = value
End Property
dList that inherit the dataStruct:
Private xArray() As dataStruct
Private listInd As Integer
Public Sub init(cnt As Integer)
ReDim xArray(1 To cnt)
Dim num As Integer
For num = 1 To cnt
Set xArray(num) = New dataStruct
Next
listInd = 1
End Sub
Property Let addArray(value As dataStruct)
Set xArray(listInd) = value
listInd = listInd + 1
End Property
How the hole list will look like:
I would strongly advocate using a dictionary. Not only is it much faster to find an item (I would assume that it is implemented with some kind of hashing), it has big advantages when it comes to adding or removing items.
When you have an array and want to add an item, you either have always to use redim preserve which is really expensive, or you define the array larger than initially needed and always have to keep the information how many items are really used. And deleting an item from an array is rather complicated.
You cannot add a typed variable as item value into a dictionary, but you can add a object. So instead of your Type definition, create a simple class module, containing only these lines (of course you can create the class with properties, getter and setter but that's irrelevant for this example)
Public id As Long
Public name As String
Public value As Long
Then, dealing with the dictionary is rather simple (note that you have to add a reference to the Microsoft Scripting Runtime
Option Explicit
Dim myList As New Dictionary
Sub AddItemValues(id As Long, name As String, value As Long)
Dim item As New clsMyData
With item
.id = id
.name = name
.value = value
End With
Call AddItem(item)
End Sub
Sub AddItem(item As clsMyData)
If myList.Exists(item.id) Then
set myList(item.id) = item
Else
Call myList.Add(item.id, item)
End If
End Sub
Function SearchItem(id As Long) As clsMyData
If myList.Exists(id) Then
Set SearchItem = myList(id)
Else
Set SearchItem = Nothing
End If
End Function
Function SearchName(name As String) As clsMyData
Dim item As Variant
For Each item In myList.Items
If item.name = name Then
Set SearchName = item
Exit Function
End If
Next item
Set SearchName = Nothing
End Function
So as long as you deal with Id's, the dictionary will do all the work for you. Only if you search for the name, you have to loop over all items of the dictionary, which is as easy as looping over an array.
Some test (of course you should add some error handling)
Sub test()
Call AddItemValues(32, "input_air", 0)
Call AddItemValues(45, "air_Procent", 99)
Call AddItemValues(89, "output_air", 34)
Debug.Print SearchItem(45).name
Debug.Print SearchName("output_air").value
' Change value of output_air
Call AddItemValues(89, "output_air", 1234)
Debug.Print SearchName("output_air").value
End Sub
I am working on a vb.net COM interop to work in Microsoft Excel and I am having trouble passing arrays from vb to vb.net. I have a PointPairs property in the vb.net code that I need to set from vb and I am having trouble passing the 2 dimensional array. I have tried both setting the property explicitly with a 2D array as well as passing two 1D arrays into a Sub to try and set the property in vb.net, but nothing I have tried seems to work.
vb.net code:
Public Property PointPairs() As Double(,)
Get
...
Return array
End Get
Set(ByVal Value(,) As Double)
...
End Set
End Property
Public Sub SetPointPairs(ByRef spline As Spline, ByRef xValues() As Double, _
ByRef yValues() As Double)
Dim Value(,) As Double
ReDim Value(1, UBound(xValues, 1))
For i As Integer = 0 To UBound(xValues, 1)
Value(0, i) = xValues(i)
Value(1, i) = yValues(i)
Next
spline.PointPairs = Value
End Sub
vb code:
Dim spline1 As New Spline
Dim points(), xValues(), yValues() As Double
'read input from excel cells into points() array/add x and y values to respective arrays
spline1.PointPairs = points 'first method (doesn't work)
Call SetPointPairs(spline1, xValues, yValues) 'second method (doesn't work)
Everything is being exported correctly by vb.net and the properties/subs/functions are visible in the Object Browser in vba, however when I try to pass arrays in these two approaches I get error messages Function or interfaces markes as restricted, or the function uses an automation type not supported in Visual Basic or Sub or Function not defined. I have also tried using <MarshalAs()> but I have never used it before and can't find much documentation on how to use it for passing arrays between vb and vb.net.
Thanks in advance for any suggestions or solutions
For anyone interested in the solution, I found this article that was exactly what I needed.
http://www.codeproject.com/Articles/12386/Sending-an-array-of-doubles-from-Excel-VBA-to-C-us?fid=247508&select=2478365&tid=2478365
I had to break up the 2D array into two 1D arrays of Doubles in VBA and pass them into vb.net as objects and modify them as outlined in the article. I changed the SetPointPairs Sub as follows and added this Private Function to convert from Object to Array in the .net code
Sub SetPointPairs(ByRef spline As CubicSpline, ByRef xValues As Object, ByRef yValues As Object) Implements iCubicSpline.SetPointPairs
Dim xDbls(), yDbls(), pointDbls(,) As Double
xDbls = ComObjectToDoubleArray(xValues)
yDbls = ComObjectToDoubleArray(yValues)
ReDim pointDbls(1, UBound(xDbls, 1))
For i As Integer = 0 To UBound(pointDbls, 2)
pointDbls(0, i) = xDbls(i)
pointDbls(1, i) = yDbls(i)
Next
spline.PointPairs = pointDbls
End Sub
Private Function ComObjectToDoubleArray(ByVal comObject As Object) As Double()
Dim thisType As Type = comObject.GetType
Dim dblType As Type = Type.GetType("System.Double[]")
Dim dblArray(0) As Double
If thisType Is dblType Then
Dim args(0) As Object
Dim numEntries As Integer = CInt(thisType.InvokeMember("Length", BindingFlags.GetProperty, _
Nothing, comObject, Nothing))
ReDim dblArray(numEntries - 1)
For j As Integer = 0 To numEntries - 1
args(0) = j
dblArray(j) = CDbl(thisType.InvokeMember("GetValue", BindingFlags.InvokeMethod, _
Nothing, comObject, args))
Next
End If
Return dblArray
End Function