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
Related
I'm trying to get the dimension of an array via PeekArray and SafeArrayGetDim API,
But the "Type mismatch" when compiling.
And if Debug.Print SafeArrayGetDim(PeekArray(TestArray).Ptr) will work fine.
Please find below the VB code.
Any help will be greatful.
Option Explicit
Private Type PeekArrayType
Ptr As Long
Reserved As Currency
End Type
Private Declare Function PeekArray Lib "kernel32" Alias "RtlMoveMemory" ( _
Arr() As Any, Optional ByVal Length As Long = 4) As PeekArrayType
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByVal Ptr As Long) As Long
Sub GetArrayDimension()
Dim TestArray() As Long
ReDim TestArray(3, 2)
Debug.Print fnSafeArrayGetDim(TestArray)
End Sub
Function fnSafeArrayGetDim(varRunArray As Variant) As Long
Dim varTmpArray() As Variant
varTmpArray = varRunArray
fnSafeArrayGetDim = SafeArrayGetDim(PeekArray(varTmpArray).Ptr)
End Function
Here is a working fnSafeArrayGetDim function
Option Explicit
#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
#If Win64 Then
Private Const PTR_SIZE As Long = 8
#Else
Private Const PTR_SIZE As Long = 4
#End If
#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#End If
Public Function fnSafeArrayGetDim(varRunArray As Variant) As Long
Const VT_BYREF As Long = &H4000
Dim lVarType As Long
Dim lPtr As LongPtr
Call CopyMemory(lVarType, varRunArray, 2)
If (lVarType And vbArray) <> 0 Then
Call CopyMemory(lPtr, ByVal VarPtr(varRunArray) + 8, PTR_SIZE)
If (lVarType And VT_BYREF) <> 0 Then
Call CopyMemory(lPtr, ByVal lPtr, PTR_SIZE)
End If
If lPtr <> 0 Then
Call CopyMemory(fnSafeArrayGetDim, ByVal lPtr, 2)
End If
End If
End Function
Private Sub Form_Load()
Dim TestArray() As Long
ReDim TestArray(3, 2)
Debug.Print fnSafeArrayGetDim(TestArray)
End Sub
You don't need PeekArray as you are dealing with pure Variants not arrays like Variant() (array of Variants), Long() (array of Longs) or Byte() (array of Bytes) generally a type ending with () in VB6 is so called SAFEARRAY in COM parlance.
So your varRunArray is a pure Variant that points to a SAFEARRAY in its pparray member which is located at VarPtr(varRunArray) + 8. Once you get this pointer you must heed the VT_BYREF flag in Variant's vt which introduces a double indirection (you have to dereference lPtr = *lPtr once more). At this point if you get a non-NULL pointer to the SAFEARRAY structure then the cDim member is in the first 2 bytes.
Here 's my solution, the ArrayDims function, adapted from wqw's post, above. In addition to wqw's basic logic, this solution will compile under VBA7/64-bit Office environments; it includes improved self-documentation and explanatory commentary; it eliminates the embedded constants and, instead, uses standard VB/VBA Type structures and Enum values where useful, and provides all associated Type elements and Enum values for reference. You can, of course, pare this down to the minimum necessary declarations and Enum values.
#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
Enum VariantTypes
VTx_Empty = vbEmpty '(0) Uninitialized
VTx_Null = vbNull '(1) No valid data
VTx_Integer = vbInteger '(2)
VTx_Long = vbLong '(3)
VTx_FloatSingle = vbSingle '(4) Single-precision floating-point
VTx_FloatDouble = vbDouble '(5) Double-precision floating-point
VTx_Currency = vbCurrency '(6)
VTx_DATE = vbDate '(7)
VTx_String = vbString '(8)
VTx_Object = vbObject '(9)
VTx_Error = vbError '(10) An Error condition code
VTx_Boolean = vbBoolean '(11)
VTx_Variant = vbVariant '(12) Used only for arrays of Variants
VTx_Byte = vbByte '(17)
VTx_UDT = vbUserDefinedType '(36) User-defined data types
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
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
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, above.
'
'*************************************************************************************************************
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
Change it to
Function fnSafeArrayGetDim(ByRef varRunArray() As Long) As Long
Dim varTmpArray() As Long
varTmpArray = varRunArray
fnSafeArrayGetDim = SafeArrayGetDim(PeekArray(varTmpArray).Ptr)
End Function
You cannot put a Dim TestArray() As Long in a Dim varTmpArray() As Variant what you try here varTmpArray = varRunArray.
If you want to be more generic then use
Function fnSafeArrayGetDim(ByRef varRunArray As Variant) As Long
Dim varTmpArray As Variant
varTmpArray = varRunArray
fnSafeArrayGetDim = SafeArrayGetDim(PeekArray(varTmpArray).Ptr)
End Function
For example:
You cannot put a Long array into a Variant array
Sub ThisDoesNotWork()
Dim TestArray() As Long
ReDim TestArray(3, 2)
Dim varTmpArray() As Variant 'with parenthesis
varTmpArray = TestArray
End Sub
but you can put a Long array into a Variant (that is not an array)
Sub ThisWorks()
Dim TestArray() As Long
ReDim TestArray(3, 2)
Dim varTmpArray As Variant 'note this is without parenthesis!
varTmpArray = TestArray
End Sub
and you can put a Long array into another Long array
Sub ThisWorksToo()
Dim TestArray() As Long
ReDim TestArray(3, 2)
Dim varTmpArray() As Long 'with parenthesis it has to be the same type as TestArray
varTmpArray = TestArray
End Sub
I don't like uninitialized VBA arrays, since it's necessary to check if array is initialized, each time prior using UBound() or For Each to avoid an exception, and there is no native VBA function to check it. That is why I initialize arrays, at least doing them empty with a = Array(). This eliminates the need for extra check in most of cases, so there are no problems with 1d arrays.
For the same reason I tried to create an empty 2d array. It's not possible simply do ReDim a(0 To -1, 0 To 0), transpose 1d empty array or something similar. The only way I came across by chance, is to use MSForms.ComboBox, assign empty array to .List property and read it back. Here is the example, which works in Excel and Word, you need to insert UserForm to VBA Project, place ComboBox on it, and add the below code:
Private Sub ComboBox1_Change()
Dim a()
ComboBox1.List = Array()
a = ComboBox1.List
Debug.Print "1st dimension upper bound = " & UBound(a, 1)
Debug.Print "2nd dimension upper bound = " & UBound(a, 2)
End Sub
After combo change the output is:
1st dimension upper bound = -1
2nd dimension upper bound = 0
Actually it's really the empty 2d array in debug:
Is there more elegant way to create an empty 2d array, without using ComboBox, or UserForm controls in general?
This is only going to work for Windows (not for Mac):
Option Explicit
#If Mac Then
#Else
#If VBA7 Then
Private Declare PtrSafe Function SafeArrayCreate Lib "OleAut32.dll" (ByVal vt As Integer, ByVal cDims As Long, ByRef rgsabound As SAFEARRAYBOUND) As LongPtr
Private Declare PtrSafe Function VariantCopy Lib "OleAut32.dll" (pvargDest As Any, pvargSrc As Any) As Long
Private Declare PtrSafe Function SafeArrayDestroy Lib "OleAut32.dll" (ByVal psa As LongPtr) As Long
#Else
Private Declare Function SafeArrayCreate Lib "OleAut32.dll" (ByVal vt As Integer, ByVal cDims As Long, ByRef rgsabound As SAFEARRAYBOUND) As Long
Private Declare Function VariantCopy Lib "OleAut32.dll" (pvargDest As Variant, pvargSrc As Any) As Long
Private Declare Function SafeArrayDestroy Lib "OleAut32.dll" (ByVal psa As Long) As Long
#End If
#End If
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type tagVariant
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
#If VBA7 Then
ptr As LongPtr
#Else
ptr As Long
#End If
End Type
Public Function EmptyArray(ByVal numberOfDimensions As Long, ByVal vType As VbVarType) As Variant
'In Visual Basic, you can declare arrays with up to 60 dimensions
Const MAX_DIMENSION As Long = 60
If numberOfDimensions < 1 Or numberOfDimensions > MAX_DIMENSION Then
Err.Raise 5, "EmptyArray", "Invalid number of dimensions"
End If
#If Mac Then
Err.Raise 298, "EmptyArray", "OleAut32.dll required"
#Else
Dim bounds() As SAFEARRAYBOUND
#If VBA7 Then
Dim ptrArray As LongPtr
#Else
Dim ptrArray As Long
#End If
Dim tVariant As tagVariant
Dim i As Long
'
ReDim bounds(0 To numberOfDimensions - 1)
'
'Make lower dimensions [0 to 0] instead of [0 to -1]
For i = 1 To numberOfDimensions - 1
bounds(i).cElements = 1
Next i
'
'Create empty array and store pointer
ptrArray = SafeArrayCreate(vType, numberOfDimensions, bounds(0))
'
'Create a Variant pointing to the array
tVariant.vt = vbArray + vType
tVariant.ptr = ptrArray
'
'Copy result
VariantCopy EmptyArray, tVariant
'
'Clean-up
SafeArrayDestroy ptrArray
#End If
End Function
You can now create empty arrays with different number of dimensions and data types:
Sub Test()
Dim arr2D() As Variant
Dim arr4D() As Double
'
arr2D = EmptyArray(2, vbVariant)
arr4D = EmptyArray(4, vbDouble)
Stop
End Sub
Update 30/09/2022
I've created an EmptyArray method (same signature) in my MemoryTools library on GitHub. That version will work on both Windows and Mac.
Idk man - I think you stumbling onto this property was pretty wild.
I'd probably stop here and just do:
Function Empty2DArray() As Variant
With CreateObject("Forms.ComboBox.1")
.List = Array()
Empty2DArray = .List
End With
End Function
And use it like: a = Empty2DArray
You don't need to create the userform or combobox - you can just use CreateObject.
But as others have said, it probably makes more sense to do error handling when checking whether or not your arrays are initialized.
Goal: populate 1-D array from 2 columns (in 2 different files) without looping.
The code where I'm trying to read the first list to an array fails on the line
MergeAccountOpportArr = NamesRng.Value
Attempted code:
Option Explicit
Public AccountsWB As Workbook
Public AccountsSht As Worksheet
' --- Columns Variables ---
Public Const NamesCol As String = "F"
' --- Public Arrays ---
Public MergeAccountOpportArr() As String
'===================================================================
Sub MergeRangestoArray()
Dim OpportWBName As String, AccountsWBName As String, WebinarWBName As String
Dim NamesRng As Rang
Dim LastRow As Long, i As Long
ReDim MergeAccountOpportArr(100000) 'init size array to very large size >> will optimize later
' open Accounts file
AccountsWBName = GetFileName(ThisWorkbook.Path, "Accounts")
' set the Accounts file workbook object
Set AccountsWB = Workbooks.Open(Filename:=AccountsWBName, ReadOnly:=True)
' set the worksheet object
Set AccountsSht = AccountsWB.Worksheets(1)
With AccountsSht
LastRow = FindLastRow(AccountsSht) ' get last row
Set NamesRng = .Range(.Cells(1, NamesCol), .Cells(LastRow, NamesCol))
MergeAccountOpportArr = NamesRng.Value ' <---- Here comes the error
End With
' rest of my code
End Sub
In theory, you should be able to do this by hacking around with the SAFEARRAY structures in memory. The indexing of the data area for a SAFEARRAY is determined by the product of the indexes of the individual dimensions, so if you have a two dimensional array where one dimension only has a single element, the memory addresses should be the same for a one dimensional array (row * 1 = row).
As proof of concept...
YOU CAN TRY THIS AT HOME KIDS, BUT THIS IS NOT PRODUCTION GRADE CODE.
'In declarations section:
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, _
ByVal length As Long)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, _
ByVal length As Long)
#End If
Private Const VT_BY_REF = &H4000&
Private Type SafeBound
cElements As Long
lLbound As Long
End Type
Private Type SafeArray
cDim As Integer
fFeature As Integer
cbElements As Long
cLocks As Long
#If VBA7 Then
pvData As LongPtr
#Else
pvData As Long
#End If
rgsabound As SafeBound
rgsabound2 As SafeBound
End Type
Public Function RangeToOneDimensionalArray(Target As Range) As Variant()
If Target.Columns.Count > 1 Or Target.Rows.Count = 1 Then
Err.Raise 5 'Invalid procedure call or argument
End If
Dim values() As Variant
values = Target.Value
If HackDimensions(values) Then
RangeToOneDimensionalArray = values
End If
End Function
Private Function HackDimensions(SafeArray As Variant) As Boolean
Dim vtype As Integer
'First 2 bytes are the VARENUM.
CopyMemory vtype, SafeArray, 2
Dim lp As Long
'Get the data pointer.
CopyMemory lp, ByVal VarPtr(SafeArray) + 8, 4
'Make sure the VARENUM is a pointer.
If (vtype And VT_BY_REF) <> 0 Then
'Dereference it for the actual data address.
CopyMemory lp, ByVal lp, 4
Dim victim As SafeArray
CopyMemory ByVal VarPtr(victim), ByVal lp, LenB(victim)
'Set the dimensions to 1
victim.cDim = 1
'Set the bound on the first dimension.
victim.rgsabound.cElements = victim.rgsabound2.cElements
CopyMemory ByVal lp, ByVal VarPtr(victim), LenB(victim)
HackDimensions = True
End If
End Function
Note that this has to swap the 2 dimensions (and the declarations are limited to 2D arrays). It also leaves the second dimension rgsabound "hanging", so you'll likely leak the memory for that structure (8 bytes) every time you run this.
The safer way would be to copy the contents of the memory area onto a new one dimensional array and use that instead, OR wrap this whole mess in a Class module and clean up after yourself when you get done.
Oh yeah, it works ;-)
Public Sub Testing()
Dim sample() As Variant
sample = RangeToOneDimensionalArray(Sheet1.Range("A1:A30"))
Dim idx As Long
For idx = 1 To 30
Debug.Print sample(idx)
Next
End Sub
This converts the ranges into a strings delimited by a specified character. It then joins the two lists into an array with split()
Note:
Delimiter will have to be a character not in your dataset
Transpose is due to your data being in columns. If your data is in rows you'll have to check it, maybe with something like a column count.
.
Sub Test()
Dim oResultArray() As String
oResultArray = MergeRngToArray(Sheet1.Range("B3:B12"), Sheet2.Range("B2:B6"))
End Sub
Private Function MergeRngToArray(ByVal Range1 As Range, ByVal Range2 As Range, Optional Delimiter As String = ",") As String()
Dim sRange1 As String
Dim sRange2 As String
sRange1 = Join(Application.WorksheetFunction.Transpose(Range1.Value), Delimiter) & Delimiter
sRange2 = Join(Application.WorksheetFunction.Transpose(Range2.Value), Delimiter)
MergeRngToArray = Split(sRange1 & sRange2, Delimiter)
End Function
Start with the easier problem of copying cells into a 1D array
You can go from a 1D array to a range easily with the following trick:
Public Sub TESTING()
Dim keyarr() As Variant
keyarr = Array("1", "2", "3", "4", "5")
Range("D3").Resize(5, 1).Value = WorksheetFunction.Transpose(keyarr)
End Sub
But the opposite is much harder because the .Value property of a range always returns a 2D array.
Except when used with the transpose function:
Public Sub TESTING()
Dim i As Long, n As Long
Dim keyarr() As Variant
n = Range(Range("B3"), Range("B3").End(xlDown)).Rows.Count
keyarr = WorksheetFunction.Transpose(Range("B3").Resize(n, 1).Value)
' keyarr is a nĂ—1 1D array
' Proof:
For i = 1 To n
Debug.Print keyarr(i)
Next i
End Sub
The trick is a) use the .Transpose() function to make a column into a single row and b) to use an array of Variant and not String. Internally the array will store strings, but the type has to be Variant.
Now the last problem is to combine two arrays
The only solution I can think of is to combine the data into a different worksheet.
Public Sub TESTING()
Dim i As Long, n1 As Long, n2 As Long
Dim vals1() As Variant, vals2() As Variant
' Pull two sets of data from two columns. You could use different sheets if you wanted.
n1 = Range(Range("B3"), Range("B3").End(xlDown)).Rows.Count
vals1 = WorksheetFunction.Transpose(Range("B3").Resize(n1, 1).Value)
n2 = Range(Range("D3"), Range("D3").End(xlDown)).Rows.Count
vals2 = WorksheetFunction.Transpose(Range("D3").Resize(n2, 1).Value)
Sheet2.Range("A1").Resize(n1, 1).Value = WorksheetFunction.Transpose(vals1)
Sheet2.Range("A1").Offset(n1, 0).Resize(n2, 1).Value = WorksheetFunction.Transpose(vals2)
Dim keyarr() As Variant
keyarr = WorksheetFunction.Transpose(Sheet2.Range("A1").Resize(n1 + n2, 1).Value)
End Sub
Array approach
Sub JoinColumnArrays(a, b)
'Purpose: join 2 vertical 1-based 2-dim datafield arrays based on two range columns
'Note: returns 2-dim array with only 1 column
'Hint: overcomes ReDim Preserve restriction to change only the last dimension!
a = Application.Index(a, Evaluate("row(1:" & UBound(a) + UBound(b) & ")"), 0)
Dim i As Long, Start As Long: Start = UBound(a) - UBound(b)
For i = 1 To UBound(b)
a(Start + i, 1) = b(i, 1) ' fills empty a elements with b elements
Next i
End Sub
The above array approach returns a 1-based 2-dim array (of only 1 "column" as 2nd dimension) with changed UBound(a) value, i.e. the sum of the original "row" count of array a plus elements count of array b.
Note that using the Application.Index() function overcomes the restriction of ReDim Preserve which only would change an array's last dimension.
Example Call
'...
Dim a as Variant, b as Variant
dim ws1 as Worksheet, ws2 as Worksheet
' Set ws1 = ... ' << change worksheet definitions to your needs
' Set ws2 = ...
a = ws1.Range("A2:B4") ' assign column data from different sheets
b = ws2.Range("C2:C3")
JoinColumnArrays a, b ' << call procedure JoinColumnArrays
'Debug.Print "column ~>" & Join(Application.Transpose(Application.Index(a, 0, 1)), ", ")
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:
I'm trying to get rid of dependencies on SCRRUN.DLL in a VB6 application. One of the things it's currently being used for is its Dictionary class. The Dictionary class has a Keys function that is supposed to return an array of the keys in the dictionary. I did a little experimentation to see what happens if there are no keys in the dictionary:
Dim D As Dictionary
Set D = New Dictionary
Dim K() As Variant
K = D.Keys
MsgBox LBound(K) & ", " & UBound(K)
I was expecting "subscript out of range", or something similar, but instead I was informed that the LBound is 0 and the UBound is -1.
So, how can I create a Variant array that has LBound 0 and UBound -1?
I've tried just using an uninitialized variant array:
Dim K() as Variant
MsgBox LBound(K) & ", " & UBound(K)
But of course that throws "Subscript out of range", as I would expect. So does erasing an uninitialized array:
Dim K() as Variant
Erase K
MsgBox LBound(K) & ", " & UBound(K)
As does erasing an initialized array:
Dim K() As Variant
ReDim K(0 To 0)
Erase K
MsgBox LBound(K) & ", " & UBound(K)
I also tried just redimming to 0 and -1, strange as that may seem:
Dim K() As Variant
ReDim K(0 To -1)
MsgBox LBound(K) & ", " & UBound(K)
But that also gives "subscript out of range".
Poking around on the web a bit, I found the following trick:
Dim K() As String
K = Split(vbNullString)
MsgBox LBound(K) & ", " & UBound(K)
And that actually does give an array with LBound 0 and UBound -1! Unforunately, it's a String array, whereas I need a Variant array. I can't very well individually copy the Strings from one array to Variants in another array, because, well, 0 to -1 and all.
Does anyone know how to make such an array, Variant() with LBound 0 and UBound -1, without using SCRRUN.DLL? Preferably also using only built-in VB6 stuff, but if you can do it if you're allowed to use some external thing (other than SCRRUN.DLL), I'm all ears. Thanks.
You can use the Array function:
Dim K()
K = Array()
MsgBox UBound(K)
OK, answering my own question (but using OLEAUT32.DLL; I'd still be interested in any solutions that are pure built-in VB6):
Private Declare Function SafeArrayCreateVector Lib "OLEAUT32.DLL" ( _
ByVal vt As VbVarType, ByVal lLbound As Long, ByVal cElements As Long) _
As Variant()
Private Const VT_VARIANT As Long = 12
(...)
Dim K() As Variant
K = SafeArrayCreateVector(VT_VARIANT, 0, 0)
MsgBox LBound(K) & ", " & UBound(K)