How do I make a VB6 variant array with UBound < LBound? - arrays

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)

Related

How to UNIVERSALLY determine the number of elements in a 1D array?

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

Why does Join() need a double transposition of a 1-dim Long array?

Why does Join() need a double transposition of a 1-dim Long array?
Due to MS Help
the Join() function requires a sourcearray as "one-dimensional array containing substrings to be joined" (btw the help site makes no difference whether it is a Variant or Long).
Note: In the VBE glossary
an array is defined as set of sequentially indexed elements having the same intrinsic data type.
It's no problem to connect 1-dim Variant arrays via Join() and
it's even possible to join numbers as well as they seem to be internally interpreted as "convert us to strings".
Issue with a 1-dim array declared as Long
In some cases I want to restrict the elements type to Long and avoid the Variant solution mentioned above. -
Declaring a "flat" array - here: Numbers() - as Long, however raises Error 5 "Invalid procedure call or argument",
if you try to connect results via a simple
'[2] Failing
Join(Numbers, "|") .
I found an interesting ► work around via a basically redundant double transposition (c.f. [1]),
as it "converts" a flat 1-dim array eventually back to the same dimension.
'[1] work around
Join(Application.Transpose(Application.Transpose(Numbers)), "|")
Question
What's the internal difference how VBA treats both cases and why does Join() need a double transposition of a 1-dim Long array here?
Example call to join a "flat" array declared as Long
In order to show the workaround code line [1] as well as the error raising code line [2],
I integrated a basic error handling showing user defined error lines (ERL), too.
VB Editor's immediate window shows Error 5 in ERL 200:
OK: [1] 3 elems: ~> 100|200|300
ERL: 200 Error No 5 Invalid procedure call or argument
Example call
Sub JoinArr()
Dim Numbers() As Long ' provide for long array Numbers()
FillNumbers 3, Numbers ' call sub procedure to assign 3 numbers to array Nums
' Numbers is now an array of 3 numbers
On Error GoTo oops
'[1] work around - why does Join() need a double transposition in a 1-dim array?
100 Debug.Print " OK: [1] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Application.Transpose(Application.Transpose(Numbers)), "|")
'[2] join an already existing "flat" array raises Error 5 "Invalid procedure call or argument"
200 Debug.Print " OK [2] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Numbers, "|")
Exit Sub
oops: Debug.Print "ERL: " & Erl & " Error No " & Err.Number & " " & Err.Description
End Sub
Sub FillNumbers called by above main procedure
Sub FillNumbers(ByVal n As Long, arr)
ReDim arr(1 To n)
arr(1) = 100
arr(2) = 200
arr(3) = 300
End Sub
Trying to Join() an array of Longs will fail:
Sub JoinTestFails()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
msg = Join(Numbers, "|")
End With
MsgBox msg
End Sub
The double use of TRANSPOSE() gets around this by generating a one-dimensional, one-based array of Variants:
Sub JoinTest()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
Arr = .Transpose(.Transpose(Numbers))
msg = LBound(Arr) & "**" & UBound(Arr) & vbCrLf
msg = msg & Join(.Transpose(.Transpose(Numbers)), "|") & vbCrLf & TypeName(Arr)
End With
MsgBox msg
End Sub
To me, this use of TRANSPOSE is non-intuitive. I would rather make the Variant array with:
Public Function MkVar(arr() As Long) As Variant
' make a variant array from a long array
Dim temp() As Variant, i As Long
ReDim temp(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
temp(i) = arr(i)
Next i
MkVar = temp
End Function
and then:
Sub JoinTest2()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
arr = MkVar(Numbers)
msg = LBound(arr) & "**" & UBound(arr) & vbCrLf
msg = msg & Join(MkVar(Numbers), "|") & vbCrLf & TypeName(arr)
MsgBox msg
End Sub

find and replace values of an array, VBA

Let assume I have an array something like this:
Dim Arr() As Variant
arr(0)= "Text<&>data"
arr(1)= "<&>recombining"
arr(2)= "that libraries<&>"
arr(3)= "<&>professional<&>user "
I would like to search inside the values and find all <&> and then replace them with and.
My efforts by .find were unsuccessful. :(
Use Replace$. Not sure if you wanted to add any whitespace? I use constants as you have fixed bounds so no calls to UBound and LBound when looping the array. Also, use typed function Replace$ as more efficient.
Option Explicit
Public Sub test()
Const START_POINT As Long = 0
Const END_POINT As Long = 3
Dim Arr(START_POINT To END_POINT) As Variant, i As Long
Arr(0) = "Text<&>data"
Arr(1) = "<&>recombining"
Arr(2) = "that libraries<&>"
Arr(3) = "<&>professional<&>user "
For i = START_POINT To END_POINT
Arr(i) = Replace$(Arr(i), "<&>", "and")
Next
For i = START_POINT To END_POINT
Debug.Print Arr(i)
Next
End Sub
You could avoid loop turning array into a string with Join(), making the replacement and finally turning it back to an array with Split() (Not tested):
Dim Arr As Variant
Arr = Array("Text<&>data", _
"<&>recombining", _
"that libraries<&>", _
"<&>professional<&>user ")
Arr = Split(Replace$(Join(Arr, "|"), "<&>", "and"), "|")

Why is my array being cleared?

I'm designing a slide checker to look for mismatched fonts and colours, and need to keep track of each colour for each shape in an array. My problem is that for some reason the array get's cleared. I've put in flags to check that the array is being properly assigned. As it moves through the loop, it correctly adds 1 to the array, updates the colour for that index, then moves forward. For some reason when it gets to the msgbox check, the array still has the correct number of indexes, but the array is empty for every shape except for the last shape in the loop. For example one shape has 5 lines, another shape has 2. I'll get a msgbox 7 times, but the first 5 are empty, and the next 2 have the actual colour.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim i As Integer
Dim a As Integer
Dim b As Integer
Dim shpCount As Integer
Dim lFindColor As Long
Dim oSl As Slide
Dim oSh As Shape
Dim colorsUsed As String
Dim fontsUsed As String
Dim lRow As Long
Dim lCol As Long
Dim shpFont As String
Dim shpSize As String
Dim shpColour As String
Dim shpBlanks As Integer: shpBlanks = 0
Dim oshpColour()
Set oSl = ActiveWindow.View.Slide
For Each oSh In oSl.Shapes
'----Shape Check----------------------------------------------------------
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
shpCount = shpCount + .TextFrame.TextRange.Runs.Count
ReDim oshpColour(1 To shpCount)
For x = 1 To .TextFrame.TextRange.Runs.Count
a = a + 1
oshpColour(a) = .TextFrame.TextRange.Runs(x).Font.Color.RGB
shpFont = shpFont & .TextFrame.TextRange.Runs(x).Font.Name & ", "
shpSize = shpSize & .TextFrame.TextRange.Runs(x).Font.Size & ", "
shpColour = shpColour & .TextFrame.TextRange.Runs(x).Font.Color.RGB & ", "
Next
End If
End If
Next
MsgBox "Shape Fonts: " & shpFont & vbCrLf & "Shape Font Sizes: " & shpSize & vbCrLf & "Shape Font Colours: " & shpColour
For b = LBound(oshpColour) To UBound(oshpColour)
MsgBox oshpColour(b)
Next
End Sub
The right way to redim an array keeping it content is as follows:
ReDim Preserve oshpColour(1 To shpCount)

ArrayList with Arrays

It seems that more "complex" ArrayLists are not widely used, since I'm unable to find any concrete, helpful info about it.
I'm trying to create an ArrayList of Arrays (and eventually an ArrayList of ArrayLists of Arrays), but I seem unable to either add Arrays to the ArrayList, or access the Array's elements. All this is done using VBScript in QTP.
(The code reads from an Excel file, which is working fine.)
Set my_sheet = ExcelObject.sheets.item(testCaseSheet)
testCase = CreateObject("System.Collections.ArrayList")
Function getTestsCaseActions (row, col)
Do While my_sheet.cells(row, 2).Value <> ""
MsgBox tempArray(0) & " -> " & tempArray(1) 'WORKS FINE - THE VALUES ARE PRINTED
testCase.Add tempArray
row = row+2
Loop
End Function
getTestsCaseActions 3, 4
'This is not working - how do I access the arrays and their values in the arraylist?
For Each ArrayItem in testCase
MsgBox ArrayItem(0)' & ", " & ArrayItem(1)
'MsgBox "Hey!"
Next
Now, I realize that For Each ArrayItem in testCase is probably wrong, but I cannot find out what to use? The elements added to the ArrayList are, after all, Arrays. If I uncomment the line MsgBox "Hey!", it's written once, even though the ArrayList should have 3 Arrays.
Short answer: The correct way to use an ArrayList Of Arrays if you just need read access (after a successful initialization):
Option Explicit
Dim alA : Set alA = CreateObject("System.Collections.Arraylist")
alA.add Split("A B C")
alA.add Split("D E F")
alA.add Split("I J K")
WScript.Echo "---- For Each In"
Dim aX
For Each aX In alA
WScript.Echo TypeName(aX), Join(aX)
Next
WScript.Echo "---- For To"
Dim i
For i = 0 To alA.Count - 1
WScript.Echo TypeName(alA(i)), Join(alA(i))
Next
output:
cscript 19915175.vbs
---- For Each In
Variant() A B C
Variant() D E F
Variant() I J K
---- For To
Variant() A B C
Variant() D E F
Variant() I J K
ReDim Preserve answer(UBound(answer) + 1):
No problems with an ArrayList Of ArrayLists of Arrays (as long we are talking about read access and you don't mess it up):
Dim alB : Set alB = CreateObject("System.Collections.Arraylist")
alB.Add alA
WScript.Echo "alB(0)(0)(0) =>", alB(0)(0)(0)
WScript.Echo "alB(0)(2)(2) =>", alB(0)(2)(2)
output:
alB(0)(0)(0) => A
alB(0)(2)(2) => K

Resources