How to find the number of dimensions that an array has? - vba

Below is a piece of code where I need to store some info about a warning message by going through messages passed. The parameter passed itself is a variant which is set by an API call to SAPListOfMessages which returns an array of String. What I've noticed however is that whenever there is more than 1 warning, the list is 2D and messageList(x-1) obviously leads to an error because it's not a proper index. What's also strange is that the for each loop seems to ignore dimensions and somehow just flatten the array and loop through it as if it were 1D. The only way around this I see is checking how many dimensions the array has before doing anything else and hence my question. I wasn't able to find any info on getting the number of dimensions - I only found info about their bounds. Is it possible to find the number of dimensions of an array in VBA? If not, how would you suggest I tackle this problem?
Sub getOverlapWarnings(ByRef messageList As Variant, ByRef warnings As Dictionary)
Dim msg As Variant
Dim x As Integer
x = 1
'look for an overlap warning message in the list of messages
For Each msg In messageList
'look for the keyword 'overlap' in the list of messages
If InStr(1, msg, "overlap") <> 0 Then
warnings.Add messageList(x - 1), msg
End If
x = x + 1
Next msg
End Sub

Is it possible to find the number of dimensions of an array in VBA?
This approach increments the possible dimensions count, 60 being the built in maximum (c.f. comment):
Private Function nDim(ByVal vArray As Variant) As Long
' Purpose: get array dimension (MS)
Dim dimnum As Long
Dim ErrorCheck As Long ' OP: As Variant
On Error GoTo FinalDimension
For dimnum = 1 To 60 ' 60 being the absolute dimensions limitation
ErrorCheck = LBound(vArray, dimnum)
Next
' It's good use to formally exit a procedure before error handling
' (though theoretically this wouldn't needed in this special case - see comment)
Exit Function
FinalDimension:
nDim = dimnum - 1
End Function
Further links (thx #ChrisNeilson)
MS Using arrays
Big Array

An array has 2 bounds: Upper and Lower.
I think you're asking where the lower bound begins.
By default, the lower bound is zero. For example:
Sub test()
Dim arr
arr = Array("a", "b", "c")
Debug.Print "Lower: " & LBound(arr), "Upper: " & UBound(arr)
End Sub
returns: Lower: 0 Upper: 2 because the 3 elements have indices of 0, 1, and 2.
Some functionality may begin at 1 by default but it's rare. One example is filling an array with a range:
Sub test()
Dim arr
arr = Range("A2:A4")
Debug.Print "Lower: " & LBound(arr), "Upper: " & UBound(arr)
End Sub
...returns: Lower: 1 Upper: 3
If you fully declare the array, you can make the upper and lower bound whatever you want:
Sub test()
Dim arr(99 To 101) As String
arr(100) = "blah"
Debug.Print "Lower: " & LBound(arr), "Upper: " & UBound(arr)
End Sub
...returns: Lower: 99 Upper: 101, but an array with declared bounds won't work with many functions (like the previous examples.
You can also set the default lower bound with an statement at the very top of each module:
Option Base 1
...but there are so many places it doens't apply it's kind of useless. (More here.)
See also:
MSDN : Declaring Arrays (Fixed & Dynamic)
MSDN : LBound Function
MSDN : UBound Function

Here's a technique that doesn't require any looping through possible array dimensions. It reads the dimension count directly from the array definition itself.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
Private Enum VariantTypes
VTx_Empty = vbEmpty '(0) Uninitialized
'...
VTx_Array = vbArray '(8192)
VTx_ByRef = &H4000 '(16384) Is an indirect pointer to the Variant's data
End Enum
Type VariantStruct 'NOTE - the added "X_..." prefixes force the VBE Locals window to display the elements in
'their correct adjacency order:
A_VariantType As Integer '(2 bytes) See the VariantTypes Enum, above.
B_Reserved(1 To 6) As Byte '(6 bytes)
C_Data As LongLong '(8 bytes) NOTE: for an array-Variant, its Data is a pointer to the array.
End Type
Type ArrayStruct 'NOTE - the added "X_..." prefixes force the VBE Locals window to display the elements in
'their correct adjacency order:
A_DimCount As Integer '(aka cDim) 2 bytes: The number of dimensions in the array.
B_FeatureFlags As Integer '(aka fFeature) 2 bytes: See the FeatureFlags Enum, below.
C_ElementSize As Long '(aka cbElements) 4 bytes: The size of each element in the array.
D_LockCount As Long '(aka cLocks) 4 bytes: The count of active locks on the array.
E_DataPtr As Long '(aka pvData) 4 bytes: A pointer to the first data element in the array.
F_BoundsInfoArr As LongLong '(aka rgsabound) 8 bytes, min.: An info-array of SA_BoundInfo elements (see below)
' that contains bounds data for each dimension of the safe-array. There is one
' SA_BoundInfo element for each dimension in the array. F_BoundsInfoArr(0) holds
' the information for the right-most dimension and F_BoundsInfoArr[A_DimCount - 1]
' holds the information for the left-most dimension. Each SA_BoundInfo element is
' 8 bytes, structured as follows:
End Type
Function ArrayDims(SomeArray As Variant) As Long 'Cast the array argument to an array-Variant (if it isn't already)
'for a uniform reference-interface to it.
'
'Returns the number of dimensions of the specified array.
'
'AUTHOR: Peter Straton
'
'CREDIT: Adapted from wqw's post at:
' https://stackoverflow.com/questions/67016151/how-to-get-array-dimensionarray-parameter-pass-error
'
'*************************************************************************************************************
Dim DataPtrOffset As Integer
Dim DimCount As Integer '= ArrayStruct.A_DimCount (2 bytes)
Dim VariantType As Integer '= VariantStruct.A_VariantType (2 bytes)
Dim VariantDataPtr As LongLong '= VariantStruct.C_Data (8 bytes). See note about array-Variants' data, above.
'Check the Variant's type
Call CopyMemory(VariantType, SomeArray, LenB(VariantType))
If (VariantType And VTx_Array) Then
'It is an array-type Variant, so get its array data-pointer
Dim VariantX As VariantStruct 'Unfortunately, in VB/VBA, you can't reference the size of a user-defined
'data-Type element without instantiating one.
DataPtrOffset = LenB(VariantX) - LenB(VariantX.C_Data) 'Takes advantage of C_Data being the last element
Call CopyMemory(VariantDataPtr, ByVal VarPtr(SomeArray) + DataPtrOffset, LenB(VariantDataPtr))
If VariantDataPtr <> 0 Then
If (VariantType And VTx_ByRef) Then
'The passed array argument was not an array-Variant, so this function-call's cast to Variant type
'creates an indirect reference to the original array, via the Variant parameter. So de-reference
'that pointer.
Call CopyMemory(VariantDataPtr, ByVal VariantDataPtr, LenB(VariantDataPtr))
End If
If VariantDataPtr <> 0 Then
'Now have a legit Array reference, so get and return its dimension-count value
Call CopyMemory(DimCount, ByVal VariantDataPtr, LenB(DimCount))
End If
End If
End If
ArrayDims = DimCount
End Function 'ArrayDims
Sub Demo_ArrayDims()
'
'Demonstrates the functionality of the ArrayDims function using a 1-D, 2-D and 3-D array of various types
'
'*************************************************************************************************************
Dim Test2DArray As Variant
Dim Test3DArray() As Long
Debug.Print 'Blank line
Debug.Print ArrayDims(Array(20, 30, 400)) 'Test 1D array
Test2DArray = [{0, 0, 0, 0; "Apple", "Fig", "Orange", "Pear"}]
Debug.Print ArrayDims(Test2DArray)
ReDim Test3DArray(1 To 3, 0 To 1, 1 To 4)
Debug.Print ArrayDims(Test3DArray)
End Sub
The SA_BoundInfo Type and FeatureFlags Enum aren't actually used by the ArrayDims routine but they're also included here for reference:
Private Type SA_BoundInfo
ElementCount As Long '(aka cElements) 4 bytes: The number of elements in the dimension.
LBoundVal As Long '(aka lLbound) 4 bytes: The lower bound of the dimension.
End Type
Enum FeatureFlags
FADF_AUTO = &H1 'Array is allocated on the stack.
FADF_STATIC = &H2 'Array is statically allocated.
FADF_EMBEDDED = &H4 'Array is embedded in a structure.
FADF_FIXEDSIZE = &H10 'Array may not be resized or reallocated.
FADF_BSTR = &H100 'An array of BSTRs.
FADF_UNKNOWN = &H200 'An array of IUnknown pointers.
FADF_DISPATCH = &H400 'An array of IDispatch pointers.
FADF_VARIANT = &H800 'An array of VARIANT type elements.
FADF_RESERVED = &HF0E8 'Bits reserved for future use.
End Enum

Related

How do I properly instantiate a VBA array and check if it's empty? [duplicate]

Passing an undimensioned array to the VB6's Ubound function will cause an error, so I want to check if it has been dimensioned yet before attempting to check its upper bound. How do I do this?
Note: the code has been updated, the original version can be found in the revision history (not that it is useful to find it). The updated code does not depend on the undocumented GetMem4 function and correctly handles arrays of all types.
Note for VBA users: This code is for VB6 which never got an x64 update. If you intend to use this code for VBA, see https://stackoverflow.com/a/32539884/11683 for the VBA version. You will only need to take the CopyMemory declaration and the pArrPtr function, leaving the rest.
I use this:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Const VT_BYREF As Long = &H4000&
' When declared in this way, the passed array is wrapped in a Variant/ByRef. It is not copied.
' Returns *SAFEARRAY, not **SAFEARRAY
Public Function pArrPtr(ByRef arr As Variant) As Long
'VarType lies to you, hiding important differences. Manual VarType here.
Dim vt As Integer
CopyMemory ByVal VarPtr(vt), ByVal VarPtr(arr), Len(vt)
If (vt And vbArray) <> vbArray Then
Err.Raise 5, , "Variant must contain an array"
End If
'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx
If (vt And VT_BYREF) = VT_BYREF Then
'By-ref variant array. Contains **pparray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->pparray;
CopyMemory ByVal VarPtr(pArrPtr), ByVal pArrPtr, Len(pArrPtr) 'pArrPtr = *pArrPtr;
Else
'Non-by-ref variant array. Contains *parray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->parray;
End If
End Function
Public Function ArrayExists(ByRef arr As Variant) As Boolean
ArrayExists = pArrPtr(arr) <> 0
End Function
Usage:
? ArrayExists(someArray)
Your code seems to do the same (testing for SAFEARRAY** being NULL), but in a way which I would consider a compiler bug :)
I just thought of this one. Simple enough, no API calls needed. Any problems with it?
Public Function IsArrayInitialized(arr) As Boolean
Dim rv As Long
On Error Resume Next
rv = UBound(arr)
IsArrayInitialized = (Err.Number = 0)
End Function
Edit: I did discover a flaw with this related to the behavior of the Split function (actually I'd call it a flaw in the Split function). Take this example:
Dim arr() As String
arr = Split(vbNullString, ",")
Debug.Print UBound(arr)
What is the value of Ubound(arr) at this point? It's -1! So, passing this array to this IsArrayInitialized function would return true, but attempting to access arr(0) would cause a subscript out of range error.
Here's what I went with. This is similar to GSerg's answer, but uses the better documented CopyMemory API function and is entirely self-contained (you can just pass the array rather than ArrPtr(array) to this function). It does use the VarPtr function, which Microsoft warns against, but this is an XP-only app, and it works, so I'm not concerned.
Yes, I know this function will accept anything you throw at it, but I'll leave the error checking as an exercise for the reader.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Function ArrayIsInitialized(arr) As Boolean
Dim memVal As Long
CopyMemory memVal, ByVal VarPtr(arr) + 8, ByVal 4 'get pointer to array
CopyMemory memVal, ByVal memVal, ByVal 4 'see if it points to an address...
ArrayIsInitialized = (memVal <> 0) '...if it does, array is intialized
End Function
I found this:
Dim someArray() As Integer
If ((Not someArray) = -1) Then
Debug.Print "this array is NOT initialized"
End If
Edit: RS Conley pointed out in his answer that (Not someArray) will sometimes return 0, so you have to use ((Not someArray) = -1).
Both methods by GSerg and Raven are undocumented hacks but since Visual BASIC 6 is no longer being developed then it is not a issue. However Raven's example doesn't work on all machines. You have to test like this.
If (Not someArray) = -1 Then
On some machines it will return a zero on others some large negative number.
In VB6 there is a function called "IsArray", but it does not check if the array has been initialized. You will receive Error 9 - Subscript out of range if you attempt to use UBound on an uninitialized array. My method is very similar to S J's, except it works with all variable types and has error handling. If a non-array variable is checked, you will receive Error 13 - Type Mismatch.
Private Function IsArray(vTemp As Variant) As Boolean
On Error GoTo ProcError
Dim lTmp As Long
lTmp = UBound(vTemp) ' Error would occur here
IsArray = True: Exit Function
ProcError:
'If error is something other than "Subscript
'out of range", then display the error
If Not Err.Number = 9 Then Err.Raise (Err.Number)
End Function
Since wanted comment on here will post answer.
Correct answer seems is from #raven:
Dim someArray() As Integer
If ((Not someArray) = -1) Then
Debug.Print "this array is NOT initialized"
End If
When documentation or Google does not immediately return an explanation people tend to call it a hack.
Although what seems to be the explanation is that Not is not only a Logical, it is also a Bitwise operator, so it handles the bit representation of structures, rather than Booleans only.
For example of another bitwise operation is here:
Dim x As Integer
x = 3 And 5 'x=1
So the above And is also being treated as a bitwise operator.
Furthermore, and worth to check, even if not the directly related with this,
The Not operator can be overloaded, which means that a class or
structure can redefine its behavior when its operand has the type of
that class or structure.
Overloading
Accordingly, Not is interpreting the array as its bitwise representation and it distinguishes output when array is empty or not like differently in the form of signed number. So it can be considered this is not a hack, is just an undocumentation of the array bitwise representation, which Not here is exposing and taking advantage of.
Not takes a single operand and inverts all the bits, including the
sign bit, and assigns that value to the result. This means that for
signed positive numbers, Not always returns a negative value, and for
negative numbers, Not always returns a positive or zero value.
Logical Bitwise
Having decided to post since this offered a new approach which is welcome to be expanded, completed or adjusted by anyone who has access to how arrays are being represented in their structure. So if anyone offers proof it is actually not intended for arrays to be treated by Not bitwise we should accept it as not a hack and actually as best clean answer, if they do or do not offer any support for this theory, if it is constructive comment on this is welcome of course.
This is modification of raven's answer. Without using API's.
Public Function IsArrayInitalized(ByRef arr() As String) As Boolean
'Return True if array is initalized
On Error GoTo errHandler 'Raise error if directory doesnot exist
Dim temp As Long
temp = UBound(arr)
'Reach this point only if arr is initalized i.e. no error occured
If temp > -1 Then IsArrayInitalized = True 'UBound is greater then -1
Exit Function
errHandler:
'if an error occurs, this function returns False. i.e. array not initialized
End Function
This one should also be working in case of split function.
Limitation is you would need to define type of array (string in this example).
When you initialite the array put an integer or boolean with a flag = 1. and query this flag when you need.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long
Private Type SafeArray
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
Private Function ArrayInitialized(ByVal arrayPointer As Long) As Boolean
Dim pSafeArray As Long
CopyMemory pSafeArray, ByVal arrayPointer, 4
Dim tArrayDescriptor As SafeArray
If pSafeArray Then
CopyMemory tArrayDescriptor, ByVal pSafeArray, LenB(tArrayDescriptor)
If tArrayDescriptor.cDims > 0 Then ArrayInitialized = True
End If
End Function
Usage:
Private Type tUDT
t As Long
End Type
Private Sub Form_Load()
Dim longArrayNotDimmed() As Long
Dim longArrayDimmed(1) As Long
Dim stringArrayNotDimmed() As String
Dim stringArrayDimmed(1) As String
Dim udtArrayNotDimmed() As tUDT
Dim udtArrayDimmed(1) As tUDT
Dim objArrayNotDimmed() As Collection
Dim objArrayDimmed(1) As Collection
Debug.Print "longArrayNotDimmed " & ArrayInitialized(ArrPtr(longArrayNotDimmed))
Debug.Print "longArrayDimmed " & ArrayInitialized(ArrPtr(longArrayDimmed))
Debug.Print "stringArrayNotDimmed " & ArrayInitialized(ArrPtr(stringArrayNotDimmed))
Debug.Print "stringArrayDimmed " & ArrayInitialized(ArrPtr(stringArrayDimmed))
Debug.Print "udtArrayNotDimmed " & ArrayInitialized(ArrPtr(udtArrayNotDimmed))
Debug.Print "udtArrayDimmed " & ArrayInitialized(ArrPtr(udtArrayDimmed))
Debug.Print "objArrayNotDimmed " & ArrayInitialized(ArrPtr(objArrayNotDimmed))
Debug.Print "objArrayDimmed " & ArrayInitialized(ArrPtr(objArrayDimmed))
Unload Me
End Sub
Based on all the information I read in this existing post this works the best for me when dealing with a typed array that starts as uninitialized.
It keeps the testing code consistent with the usage of UBOUND and It does not require the usage of error handling for testing.
It IS dependent on Zero Based Arrays (which is the case in most development).
Must not use "Erase" to clear the array. use alternative listed below.
Dim data() as string ' creates the untestable holder.
data = Split(vbNullString, ",") ' causes array to return ubound(data) = -1
If Ubound(data)=-1 then ' has no contents
' do something
End If
redim preserve data(Ubound(data)+1) ' works to increase array size regardless of it being empty or not.
data = Split(vbNullString, ",") ' MUST use this to clear the array again.
The easiest way to handle this is to insure that the array is initialized up front, before you need to check for the Ubound. I needed an array that was declared in the (General) area of the form code.
i.e.
Dim arySomeArray() As sometype
Then in the form load routine I redim the array:
Private Sub Form_Load()
ReDim arySomeArray(1) As sometype 'insure that the array is initialized
End Sub
This will allow the array to be re-defined at any point later in the program.
When you find out how big the array needs to be just redim it.
ReDim arySomeArray(i) As sometype 'i is the size needed to hold the new data
The title of the question asks how to determine if an array is initialized, but, after reading the question, it looks like the real problem is how to get the UBound of an array that is not initialized.
Here is my solution (to the the actual problem, not to the title):
Function UBound2(Arr) As Integer
On Error Resume Next
UBound2 = UBound(Arr)
If Err.Number = 9 Then UBound2 = -1
On Error GoTo 0
End Function
This function works in the following four scenarios, the first three that I have found when Arr is created by an external dll COM and the fourth when the Arr is not ReDim-ed (the subject of this question):
UBound(Arr) works, so calling UBound2(Arr) adds a little overhead, but doesn't hurt much
UBound(Arr) fails in in the function that defines Arr, but succeeds inside UBound2()
UBound(Arr) fails both in the function that defines Arr and in UBound2(), so the error handling does the job
After Dim Arr() As Whatever, before ReDim Arr(X)
For any variable declared as an array, you can easily check if the array is initialized by calling the SafeArrayGetDim API. If the array is initialized, then the return value will be non-zero, otherwise the function returns zero.
Note that you can't use this function with variants that contain arrays. Doing so will cause a Compile error (Type mismatch).
Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" (psa() As Any) As Long
Public Sub Main()
Dim MyArray() As String
Debug.Print SafeArrayGetDim(MyArray) ' zero
ReDim MyArray(64)
Debug.Print SafeArrayGetDim(MyArray) ' non-zero
Erase MyArray
Debug.Print SafeArrayGetDim(MyArray) ' zero
ReDim MyArray(31, 15, 63)
Debug.Print SafeArrayGetDim(MyArray) ' non-zero
Erase MyArray
Debug.Print SafeArrayGetDim(MyArray) ' zero
ReDim MyArray(127)
Debug.Print SafeArrayGetDim(MyArray) ' non-zero
Dim vArray As Variant
vArray = MyArray
' If you uncomment the next line, the program won't compile or run.
'Debug.Print SafeArrayGetDim(vArray) ' <- Type mismatch
End Sub
If the array is a string array, you can use the Join() method as a test:
Private Sub Test()
Dim ArrayToTest() As String
MsgBox StringArrayCheck(ArrayToTest) ' returns "false"
ReDim ArrayToTest(1 To 10)
MsgBox StringArrayCheck(ArrayToTest) ' returns "true"
ReDim ArrayToTest(0 To 0)
MsgBox StringArrayCheck(ArrayToTest) ' returns "false"
End Sub
Function StringArrayCheck(o As Variant) As Boolean
Dim x As String
x = Join(o)
StringArrayCheck = (Len(x) <> 0)
End Function
My only problem with API calls is moving from 32-bit to 64-bit OS's.
This works with Objects, Strings, etc...
Public Function ArrayIsInitialized(ByRef arr As Variant) As Boolean
On Error Resume Next
ArrayIsInitialized = False
If UBound(arr) >= 0 Then If Err.Number = 0 Then ArrayIsInitialized = True
End Function
If ChkArray(MyArray)=True then
....
End If
Public Function ChkArray(ByRef b) As Boolean
On Error goto 1
If UBound(b) > 0 Then ChkArray = True
End Function
You can solve the issue with Ubound() function, check if the array is empty by retrieving total elements count using JScript's VBArray() object (works with arrays of variant type, single or multidimensional):
Sub Test()
Dim a() As Variant
Dim b As Variant
Dim c As Long
' Uninitialized array of variant
' MsgBox UBound(a) ' gives 'Subscript out of range' error
MsgBox GetElementsCount(a) ' 0
' Variant containing an empty array
b = Array()
MsgBox GetElementsCount(b) ' 0
' Any other types, eg Long or not Variant type arrays
MsgBox GetElementsCount(c) ' -1
End Sub
Function GetElementsCount(aSample) As Long
Static oHtmlfile As Object ' instantiate once
If oHtmlfile Is Nothing Then
Set oHtmlfile = CreateObject("htmlfile")
oHtmlfile.parentWindow.execScript ("function arrlength(arr) {try {return (new VBArray(arr)).toArray().length} catch(e) {return -1}}"), "jscript"
End If
GetElementsCount = oHtmlfile.parentWindow.arrlength(aSample)
End Function
For me it takes about 0.4 mksec for each element + 100 msec initialization, being compiled with VB 6.0.9782, so the array of 10M elements takes about 4.1 sec. The same functionality could be implemented via ScriptControl ActiveX.
There are two slightly different scenarios to test:
The array is initialised (effectively it is not a null pointer)
The array is initialised and has at least one element
Case 2 is required for cases like Split(vbNullString, ",") which returns a String array with LBound=0 and UBound=-1.
Here are the simplest example code snippets I can produce for each test:
Public Function IsInitialised(arr() As String) As Boolean
On Error Resume Next
IsInitialised = UBound(arr) <> 0.5
End Function
Public Function IsInitialisedAndHasElements(arr() As String) As Boolean
On Error Resume Next
IsInitialisedAndHasElements = UBound(arr) >= LBound(arr)
End Function
Either of these two ways is valid to detect an uninitialized array, but they must include the parentheses:
(Not myArray) = -1
(Not Not myArray) = 0
' Function CountElements return counted elements of an array.
' Returns:
' [ -1]. If the argument is not an array.
' [ 0]. If the argument is a not initialized array.
' [Count of elements]. If the argument is an initialized array.
Private Function CountElements(ByRef vArray As Variant) As Integer
' Check whether the argument is an array.
If (VarType(vArray) And vbArray) <> vbArray Then
' Not an array. CountElements is set to -1.
Let CountElements = -1
Else
On Error Resume Next
' Calculate number of elements in array.
' Scenarios:
' - Array is initialized. CountElements is set to counted elements.
' - Array is NOT initialized. CountElements is never set and keeps its
' initial value of zero (since an error is
' raised).
Let CountElements = (UBound(vArray) - LBound(vArray)) + 1
End If
End Function
' Test of function CountElements.
Dim arrStr() As String
Dim arrV As Variant
Let iCount = CountElements(arrStr) ' arrStr is not initialized, returns 0.
ReDim arrStr(2)
Let iCount = CountElements(arrStr) ' arrStr is initialized, returns 3.
ReDim arrStr(5 To 8)
Let iCount = CountElements(arrStr) ' arrStr is initialized, returns 4.
Let arrV = arrStr
Let iCount = CountElements(arrV) ' arrV contains a boxed arrStr which is initialized, returns 4
Erase arrStr
Let iCount = CountElements(arrStr) ' arrStr size is erased, returns 0.
Let iCount = CountElements(Nothing) ' Nothing is not an array, returns -1.
Let iCount = CountElements(Null) ' Null is not an array, returns -1.
Let iCount = CountElements(5) ' Figure is not an array, returns -1.
Let iCount = CountElements("My imaginary array") ' Text is not an array, returns -1.
Let iCount = CountElements(Array(1, 2, 3, 4, 5)) ' Created array of Integer elements, returns 5.
Let iCount = CountElements(Array("A", "B", "C")) ' Created array of String elements, returns 3.
I see a lot of suggestions online about how to tell if an array has been initialized. Below is a function that will take any array, check what the ubound of that array is, redimension the array to ubound +1 (with or without PRESERVER) and then return what the current ubound of the array is, without errors.
Function ifuncRedimUbound(ByRef byrefArr, Optional bPreserve As Boolean)
On Error GoTo err:
1: Dim upp%: upp% = (UBound(byrefArr) + 1)
errContinue:
If bPreserve Then
ReDim Preserve byrefArr(upp%)
Else
ReDim byrefArr(upp%)
End If
ifuncRedimUbound = upp%
Exit Function
err:
If err.Number = 0 Then Resume Next
If err.Number = 9 Then ' subscript out of range (array has not been initialized yet)
If Erl = 1 Then
upp% = 0
GoTo errContinue:
End If
Else
ErrHandler.ReportError "modArray", ifuncRedimUbound, "1", err.Number, err.Description
End If
End Function
This worked for me, any bug in this?
If IsEmpty(a) Then
Exit Function
End If
MSDN
Dim someArray() as Integer
If someArray Is Nothing Then
Debug.print "this array is not initialised"
End If

VBA - Is there any alternative to the array() function to create a empty array in vba?

After August 2019 Windows update there is a problem using the array() function in VBA.
Is there any other way to create an empty array in VBA for the purpose "Using multi value combobox on a form"?
The following statement to clear/delete all the selections:
me.cmbMultivalue=Array()
The array returned by Array() is not just an uninitialized array. It's an initialized array with a lower bound of 0 and an upper bound of -1, thus containing 0 elements. This is distinct from normal, uninitialized arrays, which don't have a lower and upper bound.
You can roll your own array function (which I often do for non-variant arrays).
For a variant array, it's really easy. Just take an input ParamArray, and assign that to a variant array:
Public Function altArray(ParamArray args() As Variant) As Variant()
altArray = args
End Function
Then, you can use altArray() to get your special 0-element array.
However, I'm not sure this is also bugged for that specific version of Access. If it is, we can always create a 0-element array using WinAPI (slightly adapted version of this answer):
Public Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Public Type tagVariant
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
pSomething As LongPtr
End Type
Public Declare PtrSafe Function SafeArrayCreate Lib "OleAut32.dll" (ByVal vt As Integer, ByVal cDims As Long, ByRef rgsabound As SAFEARRAYBOUND) As LongPtr
Public Declare PtrSafe Sub VariantCopy Lib "OleAut32.dll" (pvargDest As Any, pvargSrc As Any)
Public Declare PtrSafe Sub SafeArrayDestroy Lib "OleAut32.dll" (ByVal psa As LongPtr)
Public Function CreateZeroLengthArray() As Variant
Dim bounds As SAFEARRAYBOUND 'Defaults to lower bound 0, 0 items
Dim NewArrayPointer As LongPtr 'Pointer to hold unmanaged variant array
NewArrayPointer = SafeArrayCreate(vbVariant, 1, bounds)
Dim tagVar As tagVariant 'Unmanaged variant we can manually manipulate
tagVar.vt = vbArray + vbVariant 'Holds a variant array
tagVar.pSomething = NewArrayPointer 'Make variant point to the new variant array
VariantCopy CreateZeroLengthArray, ByVal tagVar 'Copy unmanaged variant to managed return variable
SafeArrayDestroy NewArrayPointer 'Destroy the unmanaged SafeArray, leaving the managed one
End Function
When you declare a new array, it is still an empty array.
i.e. Dim x() As Variant
(1) As you mention in your question, your goal is to clear combobox values by assigning an empty array to it, it seems like this would work:
Dim EmptyArray() As Variant
Me.cmbMultivalue = EmptyArray
(2) Or if that doesn't work, assuming that Me.cmbMultivalue behaves like a regular array, the following would work:
Erase Me.cmbMultivalue
EDIT:
(3) Another possible workaround similar to (1) would be to create a non-empty array and then erase it as such:
Dim x() As Variant
x = Array(1)
Erase x
You could then use x as an empty array.
If all that fails and, as you mentioned, assigning the value Null or vbEmpty didn't work, it seems like your only options would be to revert the problematic Windows update or hope Microsoft can fix this quickly.
Alternative to clear all values from a multi-value field is with SQL. Example:
CurrentDb.Execute "DELETE Table1.Test.Value FROM Table1 WHERE ID = 1"

VBA "Type mismatch: array or user-defined type expected” on String Arrays

I have a dynamic array of strings DMAs which I declare globally.
Dim DMAs() As String
I ReDim the array and assign values to it in the CreateArrayOf function which is of type String() that returns an array of type String()
DMAs = CreateArrayOf(Sites, 2, "", False)
Public Function CreateArrayOf( _
ByRef arrayFrom() As String, _
Optional ByVal numOfChars As Integer = 2, _
Optional ByVal filterChar As String = "", _
Optional ByVal filterCharIsInteger As Boolean = False _
) As String()
Dim i As Integer, _
j As Integer, _
strn As Variant, _
switch As Boolean, _
strArray() As String
'numOfChars 2 for DMA with no filterChar
'numOfChars 3 for W with filterChar "W"
'numOfChars 3 for A with filterChar "A"
'numofChars 2 for D with filterChar "D"
ReDim strArray(LBound(arrayFrom) To LBound(arrayFrom)) 'required in order to
'not throw error on first iteration
For i = LBound(arrayFrom) To UBound(arrayFrom) 'iterate through each site
switch = False
For Each strn In strArray 'iterate through the array to find whether the
'current site already exists
If strn = Mid(arrayFrom(i), 1, numOfChars) And Not strn = "" Then
switch = True
End If
Next strn
If switch = False Then 'if it doesn't exist add it to the array
ReDim Preserve strArray(1 To UBound(strArray) + 1)
strArray(UBound(strArray) - 1) = Mid(arrayFrom(i), 1, numOfChars)
End If
Next i
CreateArrayOf = strArray 'return the new array
End Function
When I attempt to pass the DMAs array to another function OutputAnArray
Private Sub OutputAnArray(ByRef arrayToOutput() As String)
Dim i As Variant
Dim x As Integer
x = 1
For Each i In arrayToOutput
Cells(x, 6).Value = i
x = x + 1
Next i
End Sub
I get the "Type mismatch: array or user-defined type expected". Throughout the whole process I only mess with string arrays.
If I take the content of the OutputAnArray function and put it in the parent function where I'm calling it from, everything's fine.
Any help is appreciated.
I changed all String definitions to Variants
Private Sub OutputAnArray(ByRef arrayToOutput() As Variant)
The culprit was still there, so then after a whole lot of attempts to get this to compile, I removed the () from the arrayToOutput parameter and it started working.
Private Sub OutputAnArray(ByRef arrayToOutput As Variant) 'fixed
What is still perplexing is the fact that in the following function definition, the () are needed for arrayFrom.
Public Function CreateArrayOf(ByRef arrayFrom() As Variant, _ ...
I really don't get it, if anyone has any idea of an explanation, I'd love to hear it.
From the documentation:
"Arrays of any type can't be returned, but a Variant containing an array can."
If follows that the function "CreateArrayOf" does not return an array of strings: it returns a variant containing an array of strings.
The variant cannot be passed as a parameter to a function expecting an array of strings:
Private Sub OutputAnArray(ByRef arrayToOutput() As String)
It can only be passed to a function expecting a variant:
Private Sub OutputAnArray(ByRef arrayToOutput as Variant)
Conversely, DMA is an array of strings:
Dim DMAs() As String
DMA can be passed to a function expecting an array of strings:
Public Function CreateArrayOf(ByRef arrayFrom() As String, _ .
And finally, "Type mismatch: array or user-defined type expected" is a generic type mismatch message. When you pass an array of the wrong type, or a variant array, and get the error "array expected", it's not particularly helpful.
There is no problem with returning typed arrays from functions or passing typed arrays to functions as arguments. The following works as expected:
Option Explicit
Sub asdfasf()
Dim DMAs() As String
DMAs = CreateAnArray()
OutputAnArray DMAs
End Sub
Private Function CreateAnArray() As String()
Dim arr() As String
ReDim arr(1 To 5)
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = i
Next
CreateAnArray = arr
End Function
Private Sub OutputAnArray(ByRef arrayToOutput() As String)
Dim i As Long
For i = LBound(arrayToOutput) To UBound(arrayToOutput)
Debug.Print arrayToOutput(i)
Next
End Sub
Now, you never show how you actually pass the DMAs array to OutputAnArray.
I'm willing to make an educated guess that you are doing
OutputAnArray (DMAs)
which will indeed result in
Type mismatch: array or user-defined type expected
You cannot freely put parentheses in that manner. They have special meaning.
If you want parentheses to be used when calling a sub, you must use Call:
Call OutputAnArray(DMAs)
And if you don't care, omit the parentheses like in the example above:
OutputAnArray DMAs
I had the same error while passing an array (of user defined type) as an argument to a function ByRef.
In my case the problem was solved using the keyword "Call" in front of the function or the sub being called.
I don't really understand it, but to me it seems like VBA is trying to interpret the function/sub a couple of different ways in the absence of "Call" - which leads to the error message.
I personally try to avoid converting anything to a variant as long as possible.

UnNest indefinite number of nested objects in vba

I would like to take any number of objects via a ParamArray and then add them, or variables nested within them to a collection. The tricky part is that if that nested object is a container of some sort (collection, scripting dictionary or even a custom class with a count method) also has variables nested within it, I want it to return those in the collection, NOT the container.
It would go something like this, let's start by creating a use case:
Sub MakeItems()
Dim ReturnedColl as Collection
Dim aString as String
Dim TopColl as New Collection, NestedColl as New Collection, SubNestedDic as New Dictionary
Dim aRangeofManyCells as Range, aRangeofOneCell as Range
Dim anObject as newObject, NestedObject as New Object, SubNestedObject as New Object
aString = "Just a string"
Set aRangeofManyCells = Range("A1:C3")
Set aRangeofOneCell = Range("A4")
SubNestedDic.Add SubNestedObject
SubNestedDic.Add aRangeofOneCell
NestedColl.Add SubNestedDic
NestedColl.Add NestedObject
NestedColl.Add SubNestedDic
NestedColl.Add aRangeofManyCells
TopColl.Add aString
TopColl.AddNestedColl
Set ReturnedColl = UnNest(TopColl, TopColl, anObject, Range("Sheet1:Sheet3!Q1"))
For each Item in ReturnedColl
'do something
Next Item
End Sub
Here comes the part I can't figure out.
I would want to do a loop like this making the Item the new Items, and then look into each Item within item (if it has any), but without losing track of the original Items, because I'll have to go to the next Item.
Function UnNest(ParamArray Items() as Variant) as Collection
For Each Item in Items
If Item 'is a container of some sort' Then
'some kind of loop through all nests, subnests, subsubnests,...
Else
UnNest.Add Item
Endif
Next Item
End Function
So the end result should be a collection that holds:
"Just a String" from aString
9 range objects corresponding to the cells Range("A1:C3") from aRangeofManyCells
1 range object corresponding to Range("A4"), from aRangeofOneCell
The objects anObject, NestedObject, and SubNestedObject
All of the above 2x, because I put TopColl as an argument to the Function 2x
And also,
an additional anObject, because I added that as an argument to the function
3 Range objects, corresponding to Sheet1Q1, Sheet2Q2, Sheet3Q3
I know that's a tall order, but there has got to be some way to do that loop.
Thanks for any help!
This routine would appear to solve one of your use cases. Certainly it worked for me although I was not passing anything other than regular variables and arrays.
One problem I could not overcome was that I could not determine the type of an Object. Unless you can solve that problem, I do not see how to achieve your entire objective.
Sub DeNestParamArray(RetnValue() As Variant, ParamArray Nested() As Variant)
' Coded Nov 2010
' Each time a ParamArray is passed to a sub-routine, it is nested in a one
' element Variant array. This routine finds the bottom level of the nesting and
' sets RetnValue to the values in the original parameter array so that other routine
' need not be concerned with this complication.
Dim NestedCrnt As Variant
Dim Inx As Integer
NestedCrnt = Nested
' Find bottom level of nesting
Do While True
If VarType(NestedCrnt) < vbArray Then
' Have found a non-array element so must have reached the bottom level
Debug.Assert False ' Should have exited loop at previous level
Exit Do
End If
If NumDim(NestedCrnt) = 1 Then
If LBound(NestedCrnt) = UBound(NestedCrnt) Then
' This is a one element array
If VarType(NestedCrnt(LBound(NestedCrnt))) < vbArray Then
' But it does not contain an array so the user only specified
' one value; a literal or a non-array variable
' This is a valid exit from this loop
Exit Do
End If
NestedCrnt = NestedCrnt(LBound(NestedCrnt))
Else
' This is a one-dimensional, non-nested array
' This is the usual exit from this loop
Exit Do
End If
Else
Debug.Assert False ' This is an array but not a one-dimensional array
Exit Do
End If
Loop
' Have found bottom level array. Save contents in Return array.
ReDim RetnValue(LBound(NestedCrnt) To UBound(NestedCrnt))
For Inx = LBound(NestedCrnt) To UBound(NestedCrnt)
If VarType(NestedCrnt(Inx)) = vbObject Then
Set RetnValue(Inx) = NestedCrnt(Inx)
Else
RetnValue(Inx) = NestedCrnt(Inx)
End If
Next
End Sub
Public Function NumDim(ParamArray TestArray() As Variant) As Integer
' Returns the number of dimensions of TestArray.
' If there is an official way of determining the number of dimensions, I cannot find it.
' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
' By trapping that failure it can determine the last test that did not fail.
' Coded June 2010. Documentation added July 2010.
' * TestArray() is a ParamArray because it allows the passing of arrays of any type.
' * The array to be tested in not TestArray but TestArray(LBound(TestArray)).
' * The routine does not validate that TestArray(LBound(TestArray)) is an array. If
' it is not an array, the routine return 0.
' * The routine does not check for more than one parameter. If the call was
' NumDim(MyArray1, MyArray2), it would ignore MyArray2.
Dim TestDim As Integer
Dim TestResult As Integer
On Error GoTo Finish
TestDim = 1
Do While True
TestResult = LBound(TestArray(LBound(TestArray)), TestDim)
TestDim = TestDim + 1
Loop
Finish:
NumDim = TestDim - 1
End Function

VBA check if array is one dimensional

I have an array (that comes from SQL) and can potentially have one or more rows.
I want to be able to figure out if the array has just one row.
UBound doesn't seem to be helpful. For 2-dimensional arrays UBound(A,1) and UBound(A,2) returns the number of rows and columns respectively, but when the array has only one row, UBound(A,1) returns the number of columns and UBound(A,2) returns a <Subscript out of range>.
I have also seen this Microsoft help page for determining the number of dimensions in an array. It is a very horrifying solution that involves using the error handler.
How can I determine whether the array has just one row (hopefully without using the error handler)?
If you REALLY want to avoid using On Error, you can use knowledge of the SAFEARRAY and VARIANT structures used to store arrays under the covers to extract the dimension information from where it's actually stored in memory. Place the following in a module called mdlSAFEARRAY
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
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
Private Enum tagVARENUM
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
CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
If varArray.vt And (tagVARENUM.VT_ARRAY Or tagVARENUM.VT_BYREF) Then
CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
If Not lpSAFEARRAY = 0 Then
CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
GetDims = sArr.cDims
Else
GetDims = 0 'The array is uninitialized
End If
Else
GetDims = 0 'Not an array - might want an error instead
End If
End Function
Here is a quick test function to show usage:
Public Sub testdims()
Dim anotherarr(1, 2, 3) As Byte
Dim myarr() As Long
Dim strArr() As String
ReDim myarr(9)
ReDim strArr(12)
Debug.Print GetDims(myarr)
Debug.Print GetDims(anotherarr)
Debug.Print GetDims(strArr)
End Sub
I know you want to avoid using the error handler, but if it's good enough for Chip Pearson, it's good enough for me. This code (as well as a number of other very helpful array functions) can be found on his site:
http://www.cpearson.com/excel/vbaarrays.htm
Create a custom function:
Function IsArrayOneDimensional(arr as Variant) As Boolean
IsArrayOneDimensional = (NumberOfArrayDimensions(arr) = 1)
End Function
Which calls Chip's function:
Public Function NumberOfArrayDimensions(arr As Variant) As Integer
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function
I realized that my original answer can be simplified - rather than having the VARIANT and SAFEARRAY structures defined as VBA Types, all that is needed is a few CopyMemorys to get the pointers and finally the Integer result.
UPDATE: This version should work on both 32 bit and 64 bit systems (original preserved below the break for posterity):
Option Explicit
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Integer)
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim variantType As Integer
Dim pointer As LongPtr
Dim arrayDims As Integer
CopyMemory VarPtr(variantType), VarPtr(VarSafeArray), 2& 'the first 2 bytes of the VARIANT structure contain the type
If (variantType And &H2000) > 0 Then 'Array (&H2000)
'If the Variant contains an array or ByRef array, a pointer for the SAFEARRAY or array ByRef variant is located at VarPtr(VarSafeArray) + 8
CopyMemory VarPtr(pointer), VarPtr(VarSafeArray) + 8, LenB(pointer)
'If the array is ByRef, there is an additional layer of indirection through another Variant (this is what allows ByRef calls to modify the calling scope).
'Thus it must be dereferenced to get the SAFEARRAY structure
If (variantType And &H4000) > 0 Then 'ByRef (&H4000)
'dereference the pointer to pointer to get the actual pointer to the SAFEARRAY
CopyMemory VarPtr(pointer), pointer, LenB(pointer)
End If
'The pointer will be 0 if the array hasn't been initialized
If Not pointer = 0 Then
'If it HAS been initialized, we can pull the number of dimensions directly from the pointer, since it's the first member in the SAFEARRAY struct
CopyMemory VarPtr(arrayDims), pointer, 2&
GetDims = arrayDims
Else
GetDims = 0 'Array not initialized
End If
Else
GetDims = 0 'It's not an array... Type mismatch maybe?
End If
End Function
Here is the simplest complete GetDims that checks the dimensions directly through the variables in memory:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim variantType As Integer
Dim pointer As Long
Dim arrayDims As Integer
CopyMemory VarPtr(variantType), VarPtr(VarSafeArray), 2& 'the first 2 bytes of the VARIANT structure contain the type
If (variantType And &H2000) > 0 Then 'Array (&H2000)
'If the Variant contains an array or ByRef array, a pointer for the SAFEARRAY or array ByRef variant is located at VarPtr(VarSafeArray) + 8
CopyMemory VarPtr(pointer), VarPtr(VarSafeArray) + 8, 4&
'If the array is ByRef, there is an additional layer of indirection through another Variant (this is what allows ByRef calls to modify the calling scope).
'Thus it must be dereferenced to get the SAFEARRAY structure
If (variantType And &H4000) > 0 Then 'ByRef (&H4000)
'dereference the pointer to pointer to get the actual pointer to the SAFEARRAY
CopyMemory VarPtr(pointer), pointer, 4&
End If
'The pointer will be 0 if the array hasn't been initialized
If Not pointer = 0 Then
'If it HAS been initialized, we can pull the number of dimensions directly from the pointer, since it's the first member in the SAFEARRAY struct
CopyMemory VarPtr(arrayDims), pointer, 2&
GetDims = arrayDims
Else
GetDims = 0 'Array not initialized
End If
Else
GetDims = 0 'It's not an array... Type mismatch maybe?
End If
End Function
For a 2D array (or more dimensions), use this function:
Function is2d(a As Variant) As Boolean
Dim l As Long
On Error Resume Next
l = LBound(a, 2)
is2d = Err = 0
End Function
which gives :
Sub test()
Dim d1(2) As Integer, d2(2, 2) As Integer,d3(2, 2, 2) As Integer
Dim b1, b2, b3 As Boolean
b1 = is2d(d1) ' False
b2 = is2d(d2) ' True
b3 = is2d(d3) ' True
Stop
End Sub
I found Blackhawks's accepted and revised answer very instructive, so I played around with it and learned some useful things from it. Here's a slightly modified version of that code that includes a test sub at the bottom.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim variantType As Integer
Dim pointer As Long
Dim arrayDims As Integer
'The first 2 bytes of the VARIANT structure contain the type:
CopyMemory VarPtr(variantType), VarPtr(VarSafeArray), 2&
If Not (variantType And &H2000) > 0 Then
'It's not an array. Raise type mismatch.
Err.Raise (13)
End If
'If the Variant contains an array or ByRef array, a pointer for the _
SAFEARRAY or array ByRef variant is located at VarPtr(VarSafeArray) + 8:
CopyMemory VarPtr(pointer), VarPtr(VarSafeArray) + 8, 4&
'If the array is ByRef, there is an additional layer of indirection through_
'another Variant (this is what allows ByRef calls to modify the calling scope).
'Thus it must be dereferenced to get the SAFEARRAY structure:
If (variantType And &H4000) > 0 Then 'ByRef (&H4000)
'dereference the pointer to pointer to get actual pointer to the SAFEARRAY
CopyMemory VarPtr(pointer), pointer, 4&
End If
'The pointer will be 0 if the array hasn't been initialized
If Not pointer = 0 Then
'If it HAS been initialized, we can pull the number of dimensions directly _
from the pointer, since it's the first member in the SAFEARRAY struct:
CopyMemory VarPtr(arrayDims), pointer, 2&
GetDims = arrayDims
Else
GetDims = 0 'Array not initialized
End If
End Function
Sub TestGetDims()
' Tests GetDims(). Should produce the following output to Immediate Window:
'
' 1 One
' 2 Two
' Number of array dimensions: 2
Dim myArray(2, 2) As Variant
Dim iResult As Integer
myArray(0, 0) = 1
myArray(1, 0) = "One"
myArray(0, 1) = 2
myArray(1, 1) = "Two"
Debug.Print myArray(0, 0), myArray(1, 0)
Debug.Print myArray(0, 1), myArray(1, 1)
iResult = GetDims(myArray)
Debug.Print "Number of array dimensions: " & iResult
End Sub
Identify 1-row arrays without Error handling or API functions
"I want to be able to figure out if the array has just one row."
To solve OP's requirement focussing on arrays already dimensioned as 1- and 2-dim arrays,
it isn't necessary to determine the array's actual dimension, it suffices
to get the number of its "rows".
So I came across the following surprisingly simple solution considering the following:
It's possible to slice 1-dim or 2-dim arrays to isolate their first "column" via
Application.Index(arr, 0, 1).
An eventual UBound now will show the correct number of rows,
especially for the asked one-row case.
Function UBndOne(arr) As Long
'Purp: get rows count of (array) input
'Note: returns 1 as the function result for
' a) one-dimensional arrays
' b) 2-dim arrays with only one row
' UBound(arr,1) isn't helpful for 1-dim array as it would return the number of elements
UBndOne = UBound(Application.Index(arr, 0, 1))
End Function
Side note: The combined code UBound(Application.Index(arr, 0, 1)) could be applied even upon other data types than arrays, returning as well 1 as function result.