Public Sub TestAddElement()
Dim aVar() As Variant
Dim aStr() As String
'array not dimensioned
aVar = AddElement(aVar, "a")
PrintArray (aVar)
aVar = AddElement(aVar, "b")
PrintArray (aVar)
aStr = Split("x,y,z", ",")
aStr = AddElement(aStr, "w")
PrintArray (aStr)
End Sub
Public Sub PrintArray(aStr As Variant)
Dim i As Integer
For i = LBound(aStr) To UBound(aStr)
Debug.Print aStr(i)
Next i
End Sub
Public Function AddElement(ByVal vArray As Variant, ByVal vElem As Variant) As Variant
' This function adds an element to a Variant array
' and returns an array with the element added to it.
Dim vRet As Variant ' To be returned
If IsEmpty(vArray) Or Not IsDimensioned(vArray) Then
' First time through, create an array of size 1.
vRet = Array(vElem)
Else
vRet = vArray
' From then on, ReDim Preserve will work.
ReDim Preserve vRet(UBound(vArray) + 1)
vRet(UBound(vRet)) = vElem
End If
AddElement = vRet
End Function
Public Function IsDimensioned(ByRef TheArray) As Boolean
If IsArray(TheArray) Then ' we need to test it! otherwise will return false if not an array!
' If you put extensive use to this function then you might modify
' it a lil' bit so it "takes in" specific array type & you can skip IsArray
' (currently you can pass any variable).
On Error Resume Next
IsDimensioned = ((UBound(TheArray) - LBound(TheArray)) >= 0)
On Error GoTo 0
'FYI: Erros are not always generated by Ubound & LBOund
' when array is empty (when arrays are "made" empty in some "specic way").
' So we cant use usual "decide" logic: bool = (err.number <> 0))
'ie.:
' str = VBA.StrConv("", vbFromUnicode) 'generally you should use strconv when
' you plan converting string to bytearray,
' (here StrConv actually not needed for "",
' it's length is 0 anyway)
' ByteArr() = str
' UBound(ByteArr) => -1
' LBound(ByteArr) => 0
'but:
' Erase ByteArr
' UBound(ByteArr) => Causes Error
' LBound(ByteArr) => Causes Error
' NOTE: I'm not sure, but I'm guessing (based on OnErr0r "knowledge" - > [url]http://www.xtremevbtalk.com/showthread.php?threadid=105700[/url])
' that "ByteArr() = str" will cause ByteArray point to SAFEARRAY in any case,
' even if "str" is empty while "Erase ByteArr" will remove that.
' QUESTION: can we make some how empty SAFEARRAYS for other types than
' ByteArrays as well???? I can't fiqure it out right now...
' Maybe doing something in low level...
Else
'IsDimensioned = False ' is already false by default
Call Err.Raise(5, "IsDimensioned", "Invalid procedure call or argument. Argument is not an array!")
End If
End Function
Public Function HasDimension(ByRef TheArray, Optional ByRef Dimension As Long = 1) As Boolean
Dim isDim As Boolean
Dim ErrNumb As Long
Dim lb As Long
Dim errDesc As String
'HasDimension = False
If (Dimension > 60) Or (Dimension < 1) Then
Call Err.Raise(9, "HasDimension", "Subscript out of range. ""Dimension"" parameter is not in its legal borders (1 to 60)! Passed dimension value is: " & Dimension)
Exit Function
End If
On Error Resume Next
isDim = IsDimensioned(TheArray) 'IsArray & IsDimensioned in one call. If Err 5 will be generated if not Array
ErrNumb = Err.Number
If ErrNumb <> 0 Then
errDesc = Err.Description
End If
On Error GoTo 0
Select Case ErrNumb
Case 0
If isDim Then
On Error Resume Next
lb = LBound(TheArray, Dimension) 'just try to retrive Lbound
HasDimension = (Err.Number = 0)
On Error GoTo 0
End If
Case 5
Call Err.Raise(5, "HasDimension", "Invalid procedure call or argument. Argument is not an array!")
Case Else
Call Err.Raise(vbObjectError + 1, "HasDimension", _
"This is unexpected error, caused when calling ""IsDimensioned"" function!" & vbCrLf & _
"Original error: " & ErrNumb & vbCrLf & _
"Description:" & errDesc)
End Select
End Function
