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
Related
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.
I created a Public function in Module two called "t_value". I now want to use this function in the VBA code for a userform, which uses the input from the userform.
This is the function:
Public Function t_value(theta As Variant)
Dim theta_1 As Integer, theta_2 As Integer
Dim A As Variant, B As Variant, s As Variant
theta_1 = Application.WorksheetFunction.Floor(theta, 5)
theta_2 = Application.WorksheetFunction.Ceiling(theta, 5)
A = theta - theta_1
B = theta_2 - theta_1
s = A / B
t_value = s
End Function
Here is the code I would like to use the function above in:
Private Sub Submit_Click()
Dim theta As Variant, alpha As Variant, t As Variant, u As Variant
theta = UserForm1.theta_input.Value
alpha = UserForm1.alpha_input.Value
t = Application.WorksheetFunction.t_value(theta)
End Sub
Normally "Application.WorksheetFunction.[function]" works, but it wouldn't work for me in this situation - I thought it may be due to the fact I created the formula. Would it be easier to just put the formula into the Sub? I was worried about runtime. I'm rather new, so I'm not completely familiar with VBA syntax.
Application.WorksheetFunction is a class defined in the Excel library; you can find it in the Object Browser (F2):
A public Function in a standard module is just a function that can be invoked from a worksheet cell (provided it doesn't have side-effects), just as well as from anywhere in the workbook's VBA project: you can't write any VBA code that "becomes a member" of a class that's defined in a library you're referencing.
So if you have a function called MyFunction in a module called Module1, you can invoke it like this:
foo = MyFunction(args)
Or like this:
foo = Module1.MyFunction(args)
So in this case:
t = t_value(theta)
Would it be easier to just put the formula into the Sub?
Nope, because a Sub won't return a value (however, you can pass variables ByRef):
Sub t_value(theta as variant, ByRef t as Variant)
Dim theta_1 As Integer, theta_2 As Integer
Dim A As Variant, B As Variant, s As Variant
theta_1 = Application.WorksheetFunction.Floor(theta, 5)
theta_2 = Application.WorksheetFunction.Ceiling(theta, 5)
A = theta - theta_1
B = theta_2 - theta_1
s = A / B
t = s '## Assign the value to the ByRef 't' variable and it should retain its value in the calling procedure
End Sub
Whether you choose to put this function in a module (Public) or in the user form module is a design decision that depends on whether you want the function to be generally available outside of the form instance(s). Whether you choose to make this function a sub is a bit different -- I'd probably recommend against it following the general best practice that Functions should return values and Subroutines should just perform actions and/or manipulate objects.
Directly use
t = t_value(theta)
, instead of
t = Application.WorksheetFunction.t_value(theta)
Is it possible to Evaluate a String which contains a valid Excel VB Constant's Name
to return that Constant's Value?
eg
Dim ConstantName as String
Dim ConstantValue as Long
ConstantName="xlValues"
ConstantValue= UnknownFunction(ConstantName)
'would set ConstantValue=-4163
Fun!
Option Explicit
Function getConstantValue(constStr As String) As Variant
Dim oMod As VBIDE.CodeModule
Dim i As Long, _
num As Long
Set oMod = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule
For i = 1 To oMod.CountOfLines
If oMod.Lines(i, 1) = "Function tempGetConstValue() As Variant" Then
num = i + 1
Exit For
End If
Next i
oMod.InsertLines num, "tempGetConstValue = " & constStr
getConstantValue = Application.Run("tempGetConstValue")
oMod.DeleteLines num
End Function
Function tempGetConstValue() As Variant
End Function
All code must be in a module called Module1. That can be changed pretty simply by changing the text "Module1" in the routine.
You'll need to add a reference to Microsoft Visual Basic for Applications Extensibility x.x
There are a number of ways this could fail. Let me know if you have any problems with it :)
Instead of using constants, you could use a dictionary
Dim dict As Object
Sub InitialiseDict()
Set dict = CreateObject(Scripting.Dictionary)
dict("xlValues") = -4163
dict("const1") = value1
...
dict("constN") = valueN
End Sub
ConstValue = dict("xlValues")
Is using the string value necessary?
Dim anyConstant as Long
anyConstant = xlValues
msgbox anyConstant
Set anyConstant to any xl constant you please, they are all enumerated Long values.
The first solution offered is indeed much more fun however.
This question already has answers here:
How to find the number of dimensions that an array has?
(3 answers)
Closed 2 years ago.
Does anyone know how to return the number of dimensions of a (Variant) variable passed to it in VBA?
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
That's the only way I could come up with. Not pretty….
Looking at MSDN, they basically did the same.
To return the number of dimensions without swallowing errors:
#If VBA7 Then
Private Type Pointer: Value As LongPtr: End Type
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
Private Type Pointer: Value As Long: End Type
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If
Private Type TtagVARIANT
vt As Integer
r1 As Integer
r2 As Integer
r3 As Integer
sa As Pointer
End Type
Public Function GetDims(source As Variant) As Integer
Dim va As TtagVARIANT
RtlMoveMemory va, source, LenB(va) ' read tagVARIANT '
If va.vt And &H2000 Then Else Exit Function ' exit if not an array '
If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa) ' read by reference '
If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2 ' read cDims from tagSAFEARRAY '
End Function
Usage:
Sub Examples()
Dim list1
Debug.Print GetDims(list1) ' >> 0 '
list1 = Array(1, 2, 3, 4)
Debug.Print GetDims(list1) ' >> 1 '
Dim list2()
Debug.Print GetDims(list2) ' >> 0 '
ReDim list2(2)
Debug.Print GetDims(list2) ' >> 1 '
ReDim list2(2, 2)
Debug.Print GetDims(list2) ' >> 2 '
Dim list3(0 To 0, 0 To 0, 0 To 0)
Debug.Print GetDims(list3) ' >> 3 '
End Sub
#cularis and #Issun have perfectly adequate answers for the exact question asked. I'm going to question your question, though. Do you really have a bunch of arrays of unknown dimension count floating around? If you're working in Excel, the only situation where this should occur is a UDF where you might get passed either a 1-D array or a 2-D array (or a non-array), but nothing else.
You should almost never have a routine that expects something arbitrary though. And thus you probably shouldn't have a general "find # of array dimensions" routine either.
So, with that in mind, here is the routines I use:
Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9
'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
Debug.Assert IsArray(arr)
Debug.Assert dimNum > 0
'Note that it is possible for a VBA array to have no dimensions (i.e.
''LBound' raises an error even on the first dimension). This happens
'with "unallocated" (borrowing Chip Pearson's terminology; see
'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
'essentially arrays that have been declared with 'Dim arr()' but never
'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.
On Error Resume Next
Dim lb As Long
lb = LBound(arr, dimNum)
'No error (0) - array has given dimension
'Subscript out of range (9) - array doesn't have given dimension
arrHasDim = (Err.Number = ERR_VBA_NONE)
Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
On Error GoTo 0
End Function
'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 1) Then
isVect = Not arrHasDim(arg, 2)
End If
End Function
'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 2) Then
isMat = Not arrHasDim(arg, 3)
End If
End Function
Note the link to Chip Pearson's excellent web site: http://www.cpearson.com/excel/VBAArrays.htm
Also see: How do I determine if an array is initialized in VB6?. I personally don't like the undocumented behavior it relies on, and performance is rarely that important in the Excel VBA code I'm writing, but it's interesting nonetheless.
For arrays, MS has a nice method that involves looping through until an error occurs.
"This routine tests the array named Xarray by testing the LBound of each dimension. Using a For...Next loop, the routine cycles through the number of possible array dimensions, up to 60000, until an error is generated. Then the error handler takes the counter step that the loop failed on, subtracts one (because the previous one was the last one without an error), and displays the result in a message box...."
http://support.microsoft.com/kb/152288
Cleaned-up version of code (decided to write as a function, not sub):
Function NumberOfDimensions(ByVal vArray As Variant) As Long
Dim dimnum As Long
On Error GoTo FinalDimension
For dimnum = 1 To 60000
ErrorCheck = LBound(vArray, dimnum)
Next
FinalDimension:
NumberOfDimensions = dimnum - 1
End Function
Microsoft has documented the structure of VARIANT and SAFEARRAY, and using those you can parse the binary data to get the dimensions.
Create a normal code module. I call mine "mdlDims". You would use it by calling the simple function 'GetDims' and passing it an array.
Option Compare Database
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
lpSAFEARRAY As Long
data(4) As Byte
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
VT_EMPTY = &H0
VT_NULL
VT_I2
VT_I4
VT_R4
VT_R8
VT_CY
VT_DATE
VT_BSTR
VT_DISPATCH
VT_ERROR
VT_BOOL
VT_VARIANT
VT_UNKNOWN
VT_DECIMAL
VT_I1 = &H10
VT_UI1
VT_UI2
VT_I8
VT_UI8
VT_INT
VT_VOID
VT_HRESULT
VT_PTR
VT_SAFEARRAY
VT_CARRAY
VT_USERDEFINED
VT_LPSTR
VT_LPWSTR
VT_RECORD = &H24
VT_INT_PTR
VT_UINT_PTR
VT_ARRAY = &H2000
VT_BYREF = &H4000
End Enum
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim varArray As ARRAY_VARIANT
Dim lpSAFEARRAY As Long
Dim sArr As SAFEARRAY
'Inspect the Variant
CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
'If the Variant is pointing to an array...
If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then
'Get the pointer to the SAFEARRAY from the Variant
CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
'If the pointer is not Null
If Not lpSAFEARRAY = 0 Then
'Read the array dimensions from the SAFEARRAY
CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
'and return them
GetDims = sArr.cDims
Else
'The array is uninitialized
GetDims = 0
End If
Else
'Not an array, you could choose to raise an error here
GetDims = 0
End If
End Function
I presume you mean without using On Error Resume Next which most programmers dislike and which also means that during debugging you can't use 'Break On All Errors' to get the code to stop dead (Tools->Options->General->Error Trapping->Break on All Errors).
For me one solution is to bury any On Error Resume Next into a compiled DLL, in the old days this would have been VB6. Today you could use VB.NET but I choose to use C#.
If Visual Studio is available to you then here is some source. It will return a dictionary, the Dicitionary.Count will return the number of dimensions. The items will also contain the LBound and UBound as a concatenated string. I'm always querying an array not just for its dimensions but also for LBound and UBound of those dimensions so I put these together and return a whole bundle of info in a Scripting Dictionary
Here is C# source, start a Class Library calling it BuryVBAErrorsCS, set ComVisible(true) add a reference to COM library 'Microsoft Scripting Runtime', Register for Interop.
using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;
namespace BuryVBAErrorsCS
{
// Requires adding a reference to COM library Microsoft Scripting Runtime
// In AssemblyInfo.cs set ComVisible(true);
// In Build tab check 'Register for Interop'
public interface IDimensionsAndBounds
{
Scripting.Dictionary DimsAndBounds(Object v);
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IDimensionsAndBounds))]
public class CDimensionsAndBounds : IDimensionsAndBounds
{
public Scripting.Dictionary DimsAndBounds(Object v)
{
Scripting.Dictionary dicDimsAndBounds;
dicDimsAndBounds = new Scripting.Dictionary();
try
{
for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
{
long vLBound = Information.LBound((Array)v, lDimensionLoop);
long vUBound = Information.UBound((Array)v, lDimensionLoop);
string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
dicDimsAndBounds.Add(lDimensionLoop, concat);
}
}
catch (Exception)
{
}
return dicDimsAndBounds;
}
}
}
For Excel client VBA code here is some source
Sub TestCDimensionsAndBounds()
'* requires Tools->References->BuryVBAErrorsCS.tlb
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")
Dim v As Variant
v = rng.Value2
Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
Set o = New BuryVBAErrorsCS.CDimensionsAndBounds
Dim dic As Scripting.Dictionary
Set dic = o.DimsAndBounds(v)
Debug.Assert dic.Items()(0) = "1 4"
Debug.Assert dic.Items()(1) = "1 2"
Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
Set dic = o.DimsAndBounds(s)
Debug.Assert dic.Items()(0) = "1 2"
Debug.Assert dic.Items()(1) = "2 3"
Debug.Assert dic.Items()(2) = "3 4"
Debug.Assert dic.Items()(3) = "4 5"
Debug.Assert dic.Items()(4) = "5 6"
Stop
End Sub
NOTE WELL: This answer handles grid variants pulled off a worksheet with Range.Value as well as arrays created in code using Dim s(1) etc.! Some of the other answers do not do this.
I like to use the fact that with an error, the new variable-value is not charged.
To get the dimension (A_Dim) of an Array (vArray) you can use following code:
On Error Resume Next
A_Dim = -1
Do Until A = "X"
A_Dim = A_Dim + 1
A = "X"
A = UBound(vArray, A_Dim + 1)
Loop
On Error GoTo 0
Function ArrayDimension(ByRef ArrayX As Variant) As Byte
Dim i As Integer, a As String, arDim As Byte
On Error Resume Next
i = 0
Do
a = CStr(ArrayX(0, i))
If Err.Number > 0 Then
arDim = i
On Error GoTo 0
Exit Do
Else
i = i + 1
End If
Loop
If arDim = 0 Then arDim = 1
ArrayDimension = arDim
End Function
I found a pretty simple way to check, probably laden with a bunch of coding faux pas, incorrect lingo, and ill advised techniques but never the less:
Dim i as Long
Dim VarCount as Long
Dim Var as Variant
'generate your variant here
i = 0
VarCount = 0
recheck1:
If IsEmpty(Var(i)) = True Then GoTo VarCalc
i = i + 1
GoTo recheck1
VarCalc:
VarCount= i - 1
Note: VarCount will obviously return a negative number if Var(0) doesn't exist. VarCount is the max reference number for use with Var(i), i is the number of variants you have.
What about just using ubound(var) + 1? That should give you the last element of most of variables (unless it's a custom range, but in that case you should know that info already). The range of a conventional variable (for instance, when using the split function) starts with 0; ubound gives you the last item of the variable. So if you have a variable with 8 elements, for instance, it will go from 0 (lbound) to 7 (ubound), and you can know the quantity of elements just adding ubound(var) + 1. For example:
Public Sub PrintQntElements()
Dim str As String
Dim var As Variant
Dim i As Integer
str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
var = Split(str, "!")
i = UBound(var) + 1
Debug.Print "First element: " & LBound(var)
Debug.Print "Last element: " & UBound(var)
Debug.Print "Quantity of elements: " & i
End Sub
It will print this output to the Inmediate window:
First element: 0
Last element: 7
Quantity of elements: 8
Also, if you are not sure that the first element (lbound) is 0, you can just use:
i = UBound(var) - LBound(var) + 1
This question already has answers here:
How to find the number of dimensions that an array has?
(3 answers)
Closed 2 years ago.
Does anyone know how to return the number of dimensions of a (Variant) variable passed to it in VBA?
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
That's the only way I could come up with. Not pretty….
Looking at MSDN, they basically did the same.
To return the number of dimensions without swallowing errors:
#If VBA7 Then
Private Type Pointer: Value As LongPtr: End Type
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
Private Type Pointer: Value As Long: End Type
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If
Private Type TtagVARIANT
vt As Integer
r1 As Integer
r2 As Integer
r3 As Integer
sa As Pointer
End Type
Public Function GetDims(source As Variant) As Integer
Dim va As TtagVARIANT
RtlMoveMemory va, source, LenB(va) ' read tagVARIANT '
If va.vt And &H2000 Then Else Exit Function ' exit if not an array '
If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa) ' read by reference '
If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2 ' read cDims from tagSAFEARRAY '
End Function
Usage:
Sub Examples()
Dim list1
Debug.Print GetDims(list1) ' >> 0 '
list1 = Array(1, 2, 3, 4)
Debug.Print GetDims(list1) ' >> 1 '
Dim list2()
Debug.Print GetDims(list2) ' >> 0 '
ReDim list2(2)
Debug.Print GetDims(list2) ' >> 1 '
ReDim list2(2, 2)
Debug.Print GetDims(list2) ' >> 2 '
Dim list3(0 To 0, 0 To 0, 0 To 0)
Debug.Print GetDims(list3) ' >> 3 '
End Sub
#cularis and #Issun have perfectly adequate answers for the exact question asked. I'm going to question your question, though. Do you really have a bunch of arrays of unknown dimension count floating around? If you're working in Excel, the only situation where this should occur is a UDF where you might get passed either a 1-D array or a 2-D array (or a non-array), but nothing else.
You should almost never have a routine that expects something arbitrary though. And thus you probably shouldn't have a general "find # of array dimensions" routine either.
So, with that in mind, here is the routines I use:
Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9
'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
Debug.Assert IsArray(arr)
Debug.Assert dimNum > 0
'Note that it is possible for a VBA array to have no dimensions (i.e.
''LBound' raises an error even on the first dimension). This happens
'with "unallocated" (borrowing Chip Pearson's terminology; see
'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
'essentially arrays that have been declared with 'Dim arr()' but never
'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.
On Error Resume Next
Dim lb As Long
lb = LBound(arr, dimNum)
'No error (0) - array has given dimension
'Subscript out of range (9) - array doesn't have given dimension
arrHasDim = (Err.Number = ERR_VBA_NONE)
Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
On Error GoTo 0
End Function
'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 1) Then
isVect = Not arrHasDim(arg, 2)
End If
End Function
'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 2) Then
isMat = Not arrHasDim(arg, 3)
End If
End Function
Note the link to Chip Pearson's excellent web site: http://www.cpearson.com/excel/VBAArrays.htm
Also see: How do I determine if an array is initialized in VB6?. I personally don't like the undocumented behavior it relies on, and performance is rarely that important in the Excel VBA code I'm writing, but it's interesting nonetheless.
For arrays, MS has a nice method that involves looping through until an error occurs.
"This routine tests the array named Xarray by testing the LBound of each dimension. Using a For...Next loop, the routine cycles through the number of possible array dimensions, up to 60000, until an error is generated. Then the error handler takes the counter step that the loop failed on, subtracts one (because the previous one was the last one without an error), and displays the result in a message box...."
http://support.microsoft.com/kb/152288
Cleaned-up version of code (decided to write as a function, not sub):
Function NumberOfDimensions(ByVal vArray As Variant) As Long
Dim dimnum As Long
On Error GoTo FinalDimension
For dimnum = 1 To 60000
ErrorCheck = LBound(vArray, dimnum)
Next
FinalDimension:
NumberOfDimensions = dimnum - 1
End Function
Microsoft has documented the structure of VARIANT and SAFEARRAY, and using those you can parse the binary data to get the dimensions.
Create a normal code module. I call mine "mdlDims". You would use it by calling the simple function 'GetDims' and passing it an array.
Option Compare Database
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
lpSAFEARRAY As Long
data(4) As Byte
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
VT_EMPTY = &H0
VT_NULL
VT_I2
VT_I4
VT_R4
VT_R8
VT_CY
VT_DATE
VT_BSTR
VT_DISPATCH
VT_ERROR
VT_BOOL
VT_VARIANT
VT_UNKNOWN
VT_DECIMAL
VT_I1 = &H10
VT_UI1
VT_UI2
VT_I8
VT_UI8
VT_INT
VT_VOID
VT_HRESULT
VT_PTR
VT_SAFEARRAY
VT_CARRAY
VT_USERDEFINED
VT_LPSTR
VT_LPWSTR
VT_RECORD = &H24
VT_INT_PTR
VT_UINT_PTR
VT_ARRAY = &H2000
VT_BYREF = &H4000
End Enum
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim varArray As ARRAY_VARIANT
Dim lpSAFEARRAY As Long
Dim sArr As SAFEARRAY
'Inspect the Variant
CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
'If the Variant is pointing to an array...
If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then
'Get the pointer to the SAFEARRAY from the Variant
CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
'If the pointer is not Null
If Not lpSAFEARRAY = 0 Then
'Read the array dimensions from the SAFEARRAY
CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
'and return them
GetDims = sArr.cDims
Else
'The array is uninitialized
GetDims = 0
End If
Else
'Not an array, you could choose to raise an error here
GetDims = 0
End If
End Function
I presume you mean without using On Error Resume Next which most programmers dislike and which also means that during debugging you can't use 'Break On All Errors' to get the code to stop dead (Tools->Options->General->Error Trapping->Break on All Errors).
For me one solution is to bury any On Error Resume Next into a compiled DLL, in the old days this would have been VB6. Today you could use VB.NET but I choose to use C#.
If Visual Studio is available to you then here is some source. It will return a dictionary, the Dicitionary.Count will return the number of dimensions. The items will also contain the LBound and UBound as a concatenated string. I'm always querying an array not just for its dimensions but also for LBound and UBound of those dimensions so I put these together and return a whole bundle of info in a Scripting Dictionary
Here is C# source, start a Class Library calling it BuryVBAErrorsCS, set ComVisible(true) add a reference to COM library 'Microsoft Scripting Runtime', Register for Interop.
using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;
namespace BuryVBAErrorsCS
{
// Requires adding a reference to COM library Microsoft Scripting Runtime
// In AssemblyInfo.cs set ComVisible(true);
// In Build tab check 'Register for Interop'
public interface IDimensionsAndBounds
{
Scripting.Dictionary DimsAndBounds(Object v);
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IDimensionsAndBounds))]
public class CDimensionsAndBounds : IDimensionsAndBounds
{
public Scripting.Dictionary DimsAndBounds(Object v)
{
Scripting.Dictionary dicDimsAndBounds;
dicDimsAndBounds = new Scripting.Dictionary();
try
{
for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
{
long vLBound = Information.LBound((Array)v, lDimensionLoop);
long vUBound = Information.UBound((Array)v, lDimensionLoop);
string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
dicDimsAndBounds.Add(lDimensionLoop, concat);
}
}
catch (Exception)
{
}
return dicDimsAndBounds;
}
}
}
For Excel client VBA code here is some source
Sub TestCDimensionsAndBounds()
'* requires Tools->References->BuryVBAErrorsCS.tlb
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")
Dim v As Variant
v = rng.Value2
Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
Set o = New BuryVBAErrorsCS.CDimensionsAndBounds
Dim dic As Scripting.Dictionary
Set dic = o.DimsAndBounds(v)
Debug.Assert dic.Items()(0) = "1 4"
Debug.Assert dic.Items()(1) = "1 2"
Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
Set dic = o.DimsAndBounds(s)
Debug.Assert dic.Items()(0) = "1 2"
Debug.Assert dic.Items()(1) = "2 3"
Debug.Assert dic.Items()(2) = "3 4"
Debug.Assert dic.Items()(3) = "4 5"
Debug.Assert dic.Items()(4) = "5 6"
Stop
End Sub
NOTE WELL: This answer handles grid variants pulled off a worksheet with Range.Value as well as arrays created in code using Dim s(1) etc.! Some of the other answers do not do this.
I like to use the fact that with an error, the new variable-value is not charged.
To get the dimension (A_Dim) of an Array (vArray) you can use following code:
On Error Resume Next
A_Dim = -1
Do Until A = "X"
A_Dim = A_Dim + 1
A = "X"
A = UBound(vArray, A_Dim + 1)
Loop
On Error GoTo 0
Function ArrayDimension(ByRef ArrayX As Variant) As Byte
Dim i As Integer, a As String, arDim As Byte
On Error Resume Next
i = 0
Do
a = CStr(ArrayX(0, i))
If Err.Number > 0 Then
arDim = i
On Error GoTo 0
Exit Do
Else
i = i + 1
End If
Loop
If arDim = 0 Then arDim = 1
ArrayDimension = arDim
End Function
I found a pretty simple way to check, probably laden with a bunch of coding faux pas, incorrect lingo, and ill advised techniques but never the less:
Dim i as Long
Dim VarCount as Long
Dim Var as Variant
'generate your variant here
i = 0
VarCount = 0
recheck1:
If IsEmpty(Var(i)) = True Then GoTo VarCalc
i = i + 1
GoTo recheck1
VarCalc:
VarCount= i - 1
Note: VarCount will obviously return a negative number if Var(0) doesn't exist. VarCount is the max reference number for use with Var(i), i is the number of variants you have.
What about just using ubound(var) + 1? That should give you the last element of most of variables (unless it's a custom range, but in that case you should know that info already). The range of a conventional variable (for instance, when using the split function) starts with 0; ubound gives you the last item of the variable. So if you have a variable with 8 elements, for instance, it will go from 0 (lbound) to 7 (ubound), and you can know the quantity of elements just adding ubound(var) + 1. For example:
Public Sub PrintQntElements()
Dim str As String
Dim var As Variant
Dim i As Integer
str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
var = Split(str, "!")
i = UBound(var) + 1
Debug.Print "First element: " & LBound(var)
Debug.Print "Last element: " & UBound(var)
Debug.Print "Quantity of elements: " & i
End Sub
It will print this output to the Inmediate window:
First element: 0
Last element: 7
Quantity of elements: 8
Also, if you are not sure that the first element (lbound) is 0, you can just use:
i = UBound(var) - LBound(var) + 1