I thought that arrays were always passed by reference in VBA, but this example seems to be an exception:
' Class Module "C"
Private a_() As Long
Public Property Let a(a() As Long)
Debug.Print VarPtr(a(0))
a_ = a
End Property
' Standard Module
Sub test()
Dim a() As Long: ReDim a(9)
Debug.Print VarPtr(a(0)) ' output: 755115384
Dim oc As C
Set oc = New C
oc.a = a ' output: 752875104
End Sub
It's bugging me because I need to have a class containing an array and it's making an extra copy.
This seems to work, at least insofar as passing by reference:
Sub test()
Dim oc As New C
Dim a() As Long: ReDim a(9)
Debug.Print "test: " & VarPtr(a(0))
oc.Set_A a()
End Sub
In class module C:
Private a_() As Long
Public Property Let a(a() As Long)
Debug.Print "Let: " & VarPtr(a(0))
a_ = a
End Property
Function Set_A(a() As Long)
Debug.Print "Set_A: " & VarPtr(a(0))
a_ = a
End Function
I do note that the VarPtr evaluation of a(0) and oc.a_(0) is different, however, and I am not sure whether this is suitable for your needs:
Related
How to write a function that will return the number of elements in any 1D array regardless of its data type ?
So far I have devised the following function:
Function ArrLen(ByRef arr As Variant) As Long
If IsEmpty(arr) Then GoTo EmptyArr
On Error GoTo EmptyArr
ArrLen = UBound(arr) - LBound(arr) + 1
Exit Function
EmptyArr:
ArrLen = 0
End Function
I works with arrays of all built-in types, but it does not work with arrays of User-Defined Types.
Below are the contents of the entire VBA Module of a M.C.R. Example:
Option Explicit
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim ArrOfIntegersN(1 To 6) As Integer
Dim ArrOfStringsN(0 To 4) As String
Dim ArrOfShapesN(1 To 4) As Shape
Dim ArrOfVariantsN(0 To 2) As Variant
Dim ArrOfRectsN(1 To 2) As RECT
Dim ArrOfIntegers() As Integer
Dim ArrOfStrings() As String
Dim ArrOfShapes() As Shape
Dim ArrOfVariants() As Variant
Dim ArrOfRects() As RECT
Sub main()
Debug.Print ArrLen(ArrOfIntegersN) & " Integers"
Debug.Print ArrLen(ArrOfStringsN) & " Strings"
Debug.Print ArrLen(ArrOfShapesN) & " Shapes"
Debug.Print ArrLen(ArrOfVariantsN) & " Variants"
Debug.Print ArrLen(ArrOfRectsN) & " Rectangles" 'Error
Debug.Print ArrLen(ArrOfIntegers) & " Integers"
Debug.Print ArrLen(ArrOfStrings) & " Strings"
Debug.Print ArrLen(ArrOfShapes) & " Shapes"
Debug.Print ArrLen(ArrOfVariants) & " Variants"
Debug.Print ArrLen(ArrOfRects) & " Rectangles" 'Error
ReDim ArrOfIntegers(1 To 6)
ReDim ArrOfStrings(0 To 4)
ReDim ArrOfShapes(1 To 4)
ReDim ArrOfVariants(0 To 2)
ReDim ArrOfRects(1 To 2)
Debug.Print ArrLen(ArrOfIntegers) & " Integers"
Debug.Print ArrLen(ArrOfStrings) & " Strings"
Debug.Print ArrLen(ArrOfShapes) & " Shapes"
Debug.Print ArrLen(ArrOfVariants) & " Variants"
Debug.Print ArrLen(ArrOfRects) & " Rectangles" 'Error
End Sub
Function ArrLen(ByRef arr As Variant) As Long
If IsEmpty(arr) Then GoTo EmptyArr
On Error GoTo EmptyArr
ArrLen = UBound(arr) - LBound(arr) + 1
Exit Function
EmptyArr:
ArrLen = 0
End Function
The three errors that I am getting are occurring at the compilation time. The error messages are:
"Only user-defined types defined in public object modules can be coerced to or from a variant or passed to late-bound functions"
So, I am thinking: grrrrrr, it is some kind of silly VBA limitation, but then I analyze this error message in detail ...and notice that:
The User-Defined Type Rect IS defined in a Public module !!!.
The array of Rect is also declared as a Public global variable
Q1: Am I misunderstanding this error message somehow? How?
Q2: How to make the ArrLen() function universal so it can also accept arrays of User Defined Types (UDT) ?
Note: I am NOT interested in solutions that propose to use Classes in place of the User Defined Types, because I have no control of what Types are passed to my functions from a 3rd party code, which I cannot alter.
EDIT: This answer to another question indirectly answers Q1 by pointing out that Object Modules actually are Class Modules, however Q2 has been answered only by the member "Ambie" below.
As noted in the comments, user-defined types must be defined in an Object Module to be passed as a variant to a function. It's a misleading phrase because an Object Module is actually a Class Module.
However, it is possible to read the element count of an array of UDTs defined in a Module (or any array for that matter). You would achieve this by reading the SAFEARRAY structure (https://learn.microsoft.com/en-us/windows/win32/api/oaidl/ns-oaidl-safearray) which you access from the array pointer rather than the array itself.
So you could pass the array pointer into your function and thereby avoid the problem of trying to coerce the array to a variant. If, as you say in your question, you are certain the array is only 1 dimension, then coding is relatively straightforward. Arrays of more than one dimension could be used but you'd need a little bit of pointer arithmetic (still pretty trivial, though) to get to the dimension you're after. Note that the code below assumes 64-bit:
Option Explicit
Private Declare PtrSafe Function GetPtrToArray Lib "VBE7" _
Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY_1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(0) As SAFEARRAYBOUND
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Sub RunMe()
Dim arrOfRects(0 To 5) As RECT
Dim ptr As LongPtr
Dim n As Long
ptr = GetPtrToArray(arrOfRects)
n = GetElementCount(ptr)
Debug.Print n
End Sub
Private Function GetElementCount(arrPtr As LongPtr) As Long
Dim saPtr As LongPtr
Dim sa As SAFEARRAY_1D
CopyMemory saPtr, ByVal arrPtr, 8
CopyMemory sa, ByVal saPtr, LenB(sa)
GetElementCount = sa.rgsabound(0).cElements
End Function
I have assigned a refedit selected range to an array called dataarray0 I have declared it as public and then use this array in the main subroutine. However, when I run from the Private sub through to the main subroutine, I get subscript out of range error which I just can't figure out. Please find below two codes 1 is the code for the USERFORM that defines the array and 2 the code which uses this array:
Option Explicit
Public dataarray0 As Variant
Private Sub ActiWorkBook_Change()
If ActiWorkBook <> "" Then Application.Workbooks(ActiWorkBook.Text).Activate
Label1.Caption = "": RefEdit1 = ""
End Sub
Private Sub CommandButton1_Click()
Unload Me
End
End Sub
Private Sub CommandButton2_Click()
Dim addr As String, partderivrng As Range, cell As Range, thisbook As String, NROWSPDIV As Integer
Dim NCOLSPDIV As Integer
Dim mydestination As Range
Dim dataarray0() As Variant, DEST As Variant
If RefEdit1.Value = "" Then
Partderiv.Hide
ERR1.Show
Else
addr = RefEdit1.Value
Set partderivrng = Range(addr)
NROWSPDIV = Range(addr).Rows.Count
NCOLSPDIV = Range(addr).Columns.Count
' ReDim dataarray0(NROWSPDIV, NCOLSPDIV)
dataarray0() = partderivrng
ThisWorkbook.Activate
Sheets("PD").Select
Set mydestination = Application.InputBox(Prompt:= _
"What is the first cell in the destination range for data?", Type:=8)
mydestination.Select
' mydestination.Paste Link:=True
Partderiv.Hide
Set DEST = mydestination.Resize(NROWSPDIV, NCOLSPDIV)
DEST.Value = dataarray0
End If
Data1.Show
End
End Sub
Private Sub CommandButton3_Click()
Unload Me
DYNA1.Show
End Sub
Private Sub UserForm_Initialize()
Dim wb As Workbook
For Each wb In Application.Workbooks
ActiWorkBook.AddItem wb.Name
Next
ActiWorkBook = ActiveWorkbook.Name
Partderiv.RefEdit1.Text = ""
End Sub
Private Sub RefEdit1_Change()
Label1.Caption = ""
If RefEdit1.Value <> "" Then _
Label1.Caption = "[" & ActiWorkBook & "]" & RefEdit1
End Sub
Sub CALC1_Run(ByRef dataarray1 As Variant, ByRef dataarray0 As Variant)
' This subroutine runs the calculation for the Isolated brick: Simple KWR Strength Calculation
' Created 27/11/2019 by Owen Booler
' Version 1: 27/11/2019 - Creation of subroutine by Owen Booler
'Integer definitions
' Loop Identifiers
Dim i As Integer, j As Integer, k As Integer
' Other Variables
Dim NSIM As Integer, NSITES As Integer, NKWRS As Integer, NTIME As Integer, NHITS As Integer
' Double Precision definitions
' String definitions
Dim DIST As String
' Array definitions
Dim Prob() As Double, SAMPSTRENGTH() As Double, SDV23 As Double, IRRSAMPSTRENGTH() As Variant
Dim NEWARRAY() As Variant, HITTIME() As Double
' Range definitions
Dim DEST1 As Range, DEST2 As Range
Randomize
' Defintions for Testing
NSIM = 1000
DIST = "N"
NTIME = Val(DYNA1.NUMTINC) + 2
' Real definitions
'NSIM = Val(MCINPUT1.NUMSIM)
'DIST = Val(MCINPUT1.DSTRENGTH)
NSITES = 16 ' Number of cracking sites
NKWRS = 16
'Re define arrays to match size of number of simulations
ReDim SAMPSTRENGTH(NSIM, NKWRS), Prob(NSIM, NKWRS), IRRSAMPSTRENGTH(NSIM, NKWRS)
ReDim NEWARRAY(2, NKWRS)
ReDim HITTIME(NTIME)
'NEWARRAY = Array(Data1.dataarray1)
For i = 1 To NSIM
' Calculate Sample Strength
If DIST = "N" Then
For j = 1 To NKWRS
HITTIME(0) = 0
NHITS = 0
Prob(i, j) = Rnd()
SAMPSTRENGTH(i, j) = sabNORMINV(Prob(i, j), 27.5653, 1.1777)
' SAMPSTRENGTH(i, j) = sabNORMINV(Prob, Val(MCINPUT1.MSTRENGTH), Val(MCINPUT1.SSTRENGTH))
IRRSAMPSTRENGTH(i, j) = SAMPSTRENGTH(i, j) * dataarray1(2, j + 1)
For k = 1 To NTIME
' Maybe put a check in here to see whether keyway root are the same in stress and strength
If dataarray0(k + 2, j + 1) > IRRSAMPSTRENGTH(i, j) Then
NHITS = NHITS + 1
HITTIME(k) = dataarray0(k + 2, 1)
Else
HITTIME(k) = HITTIME(k - 1)
End If
If HITTIME(k) = 0 Then
GoTo 10
ElseIf HITTIME(k) < HITTIME(k - 1) Then
HITTIME(j) = HITTIME(k)
Else
End If
10 Next
Next
Else
MsgBox "ERROR - VALUE FOR DISTRIBUTION NOT RECOGNISED"
End
End If
Next
Set DEST1 = Sheets("Sample").Range("B2").Resize(NSIM + 1, NKWRS + 1)
Set DEST2 = Sheets("Data").Range("B10").Resize(NSIM + 1, NKWRS + 1)
DEST1.Value = IRRSAMPSTRENGTH
DEST2.Value = SAMPSTRENGTH
End Sub
The Public variable dataarray0 declared in the module is not modified in the Sub CommandButton2_Click because you also defined a local variable with the same name in the sub.
Hence all access to dataarray0 in the Sub are made on the local defined variable, not the global public one. And when trying to access the variable from another place, you are accessing an uninitialized Variant.
If it is not useful, remove the local unneeded local variable which is masking the global one.
Private Sub CommandButton2_Click()
Dim addr As String, partderivrng As Range, cell As Range, thisbook As String, NROWSPDIV As Integer
Dim NCOLSPDIV As Integer
Dim mydestination As Range
'Dim dataarray0() As Variant, DEST As Variant
Dim DEST As Variant
.
.
.
End Sub
Edit:
In your current code, the public declaration is:
Public dataarray0 As Variant
A variant can contain an array, so the syntax dataarray0 = partdelivery will assign the content of the range to the variable, which will then become of type Variant/Variant array
And you will access data like this:
You won't be able to declare dataarray0 as an array of Variant like this, at least not at module scope:
Public dataarray0() As Variant 'WRONG -> compile error
I have found that because dataarray0 is declared as public in a userform that it doesn't behave as a global variable and therefore when I use it in my module I should put the userform name prior to the use of dataarray0 i.e.
Partderiv.dataarray0 this seems to now work
Thanks
I have some code I am moving from VB.NET to VBA which has worked in the .NET world quite well. I have successfully moved almost all of the code into the VBA world with one exception thus far. Here is much of the code in question and all the variable declarations`
Dim vault As IEdmVault14
Dim eFile As IEdmFile9
Dim eFolder As IEdmFolder7
Dim pos As IEdmPos5
Dim Pathlist As EdmStrLst5
Dim parentFolder As IEdmFolder5
Dim vaultName As String
Dim filePath As String
Dim AssyName As String
Dim LoggedIn As Boolean
Set EdmVault5 = New EdmVault5
Set vault = New EdmVault5Dim fso As New FileSystemObject
Dim sw As TextStream
Set sw = fso.CreateTextFile("c:\temp\" & AssyName & ".txt")
'-----------------------------GET COLUMN HEADERS
Dim columns() As EdmBomColumn
BOM.GetColumns columns
Dim header As String
header = "LEVEL" & vbTab
Dim column As EdmBomColumn
For i = 0 To UBound(columns)
header = header & columns(i).mbsCaption & vbTab
Next
sw.writeline (header)
'-----------------------------Bom.READ EACH BOM ROW
Dim rows As Object
Dim row As IEdmBomCell
BOM.GetRows (rows)
For i = 0 To UBound(rows)
If IsNothing(row) Then Exit For
Dim rowString As String
Set rowString = row.GetTreeLevel.ToString & vbTab
Dim varVal As String
varVal = ""
For i = 0 To UBound(columns)
row.GetVar(column.mlVariableID, column.meType, varVal, Nothing, Nothing, Nothing)
If IsNothing(varVal) Then varVal = ""
rowString = rowString & varVal & vbTab
Next
'-----------------------------WRITE THE ROW TO THE FILE
sw.writeline (rowString)
Next
sw.Close
`
The array error occurs at BOM.GetRows (rows). I am stuck on what the issue could be. This error code does not occur in VB.NET but .NET does warn that Variable 'rows' is passed by reference before it has been assigned a value. A null reference exception could result at runtime. I am not clear on how that translates into VBA if at all.
If anyone could shed some light on this it would be helpful I'm sure.
If you have a method signature (or function signature or whatever) that requires an array, then you have to Dim the variable you pass in as an array.
Public Sub test()
Dim x As Variant
Debug.Assert Not IsArray(x)
x = Array(1, 2)
Debug.Assert IsArray(x)
GetStuff x 'this fails
Stop
End Sub
Public Function GetStuff(a() As Variant) As Double
GetStuff = 1
End Function
Even though a Variant can hold an array, it doesn't pass the IsArray test just by declaring it. If I assign an array to it, it passes IsArray, but I still can't use it as an argument to function that requires an array. x is a Variant array and a() is an array of Variants. So the above code still won't compile.
It sounds from your comments that you got it sorted, but I thought I'd throw a little more information out there for posterity.
so I am looking to either index a variable that is defined in a UDT of structpairofdice or erase the memory of the static intRollNum variable later on in the code. Preferably I'd like to index the sumdice variable although I haven't been able to figure it out, help is much appreciated
Option Explicit
Type structPairOfDice
diceOne As Integer
diceTwo As Integer
rollNum As Integer
sumDice As Variant
End Type
'Randomizes the dice between 1 and 6
Function RandomizeDice() As Integer
RandomizeDice = Application.WorksheetFunction.RandBetween(1, 6)
End Function
Sub RollDice(structDice As structPairOfDice)
Static intRollNum As Integer
intRollNum = intRollNum + 1
With structDice
.rollNum = intRollNum
.diceOne = RandomizeDice()
.diceTwo = RandomizeDice()
.sumDice = .diceOne + .diceTwo
End With
End Sub
Sub PrintResults(structDice As structPairOfDice)
Call RollDice(structDice)
With structDice
Debug.Print "Roll #: " & .rollNum
Debug.Print "Dice: " & .diceOne & ", " & .diceTwo
Debug.Print "Sum: "; .sumDice
End With
End Sub
Sub Main()
Dim structDice As structPairOfDice
SetThePoint structDice
'PrintResults structDice
End Sub
You can check these two questions and see that you may prefer to use a Class rather than a UDT for this:
Only user-defined type defined in public object modules can be coerced when trying to call an external VBA function
User Defined Type (UDT) as parameter in public Sub in class module (VB6)
You can code a class like this:
clsDice
Option Explicit
Public diceOne As Long
Public diceTwo As Long
Public rollNum As Long
Public sumDice As Long
Public Sub RollDice()
diceOne = Application.WorksheetFunction.RandBetween(1, 6)
diceTwo = Application.WorksheetFunction.RandBetween(1, 6)
sumDice = diceOne + diceTwo
End Sub
Private Sub Class_Initialize()
RollDice
End Sub
So when you create the class, RollDice is called straight away and rollNum can be set to whatever you need as it is Public.
Then, in a standard module you can do this to 'play the game' and use a Dictionary to store the results of each throw of the dice:
Module1
Option Explicit
Sub PlayGame()
Dim objDiceDic As Object
Dim objDice As clsDice
Dim lngMaxRounds As Long
Dim lngRound As Long
' dictionary for game simulation
Set objDiceDic = CreateObject("Scripting.Dictionary")
' arbitrary number of rounds
lngMaxRounds = 10
For lngRound = 1 To lngMaxRounds
' creating a new dice class does the rolls for you
Set objDice = New clsDice
' set the rollNum to this round
objDice.rollNum = lngRound
' add the dice object to our throw tracking dictionary
objDiceDic.Add lngRound, objDice
Next lngRound
' test the simulation output
For lngRound = 1 To lngMaxRounds
With objDiceDic(lngRound)
Debug.Print "Roll #: " & .rollNum
Debug.Print "Dice: " & .diceOne & ", " & .diceTwo
Debug.Print "Sum: "; .sumDice
End With
Next lngRound
End Sub
So each 'round' becomes the key into the dictionary, where the value is an clsDice object where you have also stored the round (rollNum). So you can easily use the dictionary keys to access the results of a particular round e.g.
Debug.Print objDiceDic(4).sumDice
I'm having a bit of a problem working with arrays in VBA, where the same would be trivial in (almost) any other language:
Public Function getArray() As MyType()
'do a lot of work which returns an array of an unknown length'
'this is O(N^2) or something equally intensive so I only want to call this once'
End Function
Public Sub doSomething()
Dim myArray() As MyType
Set myArray = getArray() 'FAILS with "Cannot assign to array error"'
End Sub
I think it might be that I need to define the length of the array in advance, or ReDim a dynamic array. But I don't know the length of the returned array ahead of time, and I'd like to avoid calling the function twice:
Public Sub doSomething()
Dim myArray(0 To UBound(getArray()) As MyType 'not entirely sure if this would work, but it involves calling getArray twice which I'd like to avoid
Set myArray = getArray()
End Sub
In C# or Java the equivalent would be:
public MyType[] getArray(){
//do some work and return an array of an unknown length
}
public void doSomething(){
MyType[] myArray;
myArray = getArray(); //one line and I don't need to define the length of array beforehand
}
When assigning arrays of custom objects in vba you need to pass them around as variants I've included a full working sample.
Class Module named MyType:
Public Once As Integer
Public Twice As Integer
Public Thrice As Integer
Code in standard module:
Public Function getArray() As MyType()
Dim i As Integer, arr() As MyType
'do a lot of work which returns an array of an unknown length'
'this is O(N^2) or something equally intensive so I only want to call this once'
For i = 0 To Int(Rnd() * 6) + 1
ReDim Preserve arr(i)
Set arr(i) = New MyType
arr(i).Once = i
arr(i).Twice = i * 2
arr(i).Thrice = i * 3
Next i
getArray = arr
MsgBox "Long process complete"
End Function
Public Sub doSomething()
Static myArray() As MyType
Dim i As Integer
If UBound(myArray) = -1 Then
myArray = getArray()
End If
For i = LBound(myArray) To UBound(myArray)
Debug.Print myArray(i).Once & vbTab & _
myArray(i).Twice & vbTab & _
myArray(i).Thrice
Next i
End Sub
Public Sub Test()
Dim i As Integer
For i = 1 To 3
Debug.Print "Run Number " & i & vbCrLf & String(10, "-")
doSomething
Debug.Print
Next i
End Sub
The first time you run doSomething an array of random length will be generated and you will see a message box that says "Long process complete". Subsequent calls to doSomething will re-use the array created the first time.
If you copy this code and just run the Test sub it will call doSomething three times. You will see the message box once and the output of doSomething in the immediate window three times.
Well, you could pass the array as a reference to the function like this:
Public Sub MyFunc(ByRef arr() As MyType)
...
End Sub
Dim myArr() as MyType
MyFunc myArr
Inside the function you can ReDim your array as wanted.
It is indeed possible to return an array from a function in VBA. According to MSDN:
[Y]ou can also call a procedure that returns an array and assign that to another array. [ . . . ] Note that to return an array from a procedure, you simply assign the array to the name of the procedure.
So you just need to modify your existing code by removing Set from the assignment statement:
Public Function getArray() As MyType()
'do a lot of work which returns an array of an unknown length'
'this is O(N^2) or something equally intensive so I only want to call this once'
End Function
Public Sub doSomething()
Dim myArray() As MyType
myArray = getArray
End Sub
I think you just need to get rid of the set in Set myArray = getArray()
This behaves properly:
Option Explicit
Public Function getArray() As Integer()
Dim test(1 To 5) As Integer
test(1) = 2
test(2) = 4
getArray = test
End Function
Public Sub doSomething()
Dim myArray() As Integer
myArray = getArray()
Debug.Print (myArray(2))
End Sub