2992 lines
No EOL
122 KiB
XML
2992 lines
No EOL
122 KiB
XML
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
|
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Array" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
|
|
REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
|
|
REM === Full documentation is available on https://help.libreoffice.org/ ===
|
|
REM =======================================================================================================================
|
|
|
|
Option Compatible
|
|
Option Explicit
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
''' SF_Array
|
|
''' ========
|
|
''' Singleton class implementing the "ScriptForge.Array" service
|
|
''' Implemented as a usual Basic module
|
|
''' Only 1D or 2D arrays are considered. Arrays with more than 2 dimensions are rejected
|
|
''' With the noticeable exception of the CountDims method (>2 dims allowed)
|
|
''' The first argument of almost every method is the array to consider
|
|
''' It is always passed by reference and left unchanged
|
|
'''
|
|
''' Detailed user documentation:
|
|
''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_array.html?DbPAR=BASIC
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
|
|
REM ================================================================== EXCEPTIONS
|
|
|
|
Const ARRAYSEQUENCEERROR = "ARRAYSEQUENCEERROR" ' Incoherent arguments
|
|
Const ARRAYINSERTERROR = "ARRAYINSERTERROR" ' Matrix and vector have incompatible sizes
|
|
Const ARRAYINDEX1ERROR = "ARRAYINDEX1ERROR" ' Given index does not fit in array bounds
|
|
Const ARRAYINDEX2ERROR = "ARRAYINDEX2ERROR" ' Given indexes do not fit in array bounds
|
|
Const CSVPARSINGERROR = "CSVPARSINGERROR" ' Parsing error detected while parsing a csv file
|
|
Const CSVOVERFLOWWARNING = "CSVOVERFLOWWARNING" ' Array becoming too big, import process of csv file is interrupted
|
|
|
|
REM ============================================================ MODULE CONSTANTS
|
|
|
|
Const MAXREPR = 50 ' Maximum length to represent an array in the console
|
|
|
|
REM ===================================================== CONSTRUCTOR/DESTRUCTOR
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Dispose() As Variant
|
|
Set Dispose = Nothing
|
|
End Function ' ScriptForge.SF_Array Explicit destructor
|
|
|
|
REM ================================================================== PROPERTIES
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get ObjectType As String
|
|
''' Only to enable object representation
|
|
ObjectType = "SF_Array"
|
|
End Property ' ScriptForge.SF_Array.ObjectType
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get ServiceName As String
|
|
''' Internal use
|
|
ServiceName = "ScriptForge.Array"
|
|
End Property ' ScriptForge.SF_Array.ServiceName
|
|
|
|
REM ============================================================== PUBLIC METHODS
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Append(Optional ByRef Array_1D As Variant _
|
|
, ParamArray pvArgs() As Variant _
|
|
) As Variant
|
|
''' Append at the end of the input array the items listed as arguments
|
|
''' Arguments are appended blindly
|
|
''' each of them might be a scalar of any type or a subarray
|
|
''' Args
|
|
''' Array_1D: the pre-existing array, may be empty
|
|
''' pvArgs: a list of items to append to Array_1D
|
|
''' Return:
|
|
''' the new extended array. Its LBound is identical to that of Array_1D
|
|
''' Examples:
|
|
''' SF_Array.Append(Array(1, 2, 3), 4, 5) returns (1, 2, 3, 4, 5)
|
|
|
|
Dim vAppend As Variant ' Return value
|
|
Dim lNbArgs As Long ' Number of elements to append
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Append"
|
|
Const cstSubArgs = "Array_1D, arg0[, arg1] ..."
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vAppend = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMax = UBound(Array_1D)
|
|
lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based
|
|
If lMax < LBound(Array_1D) Then ' Initial array is empty
|
|
If lNbArgs > 0 Then
|
|
ReDim vAppend(0 To lNbArgs - 1)
|
|
End If
|
|
Else
|
|
vAppend() = Array_1D()
|
|
If lNbArgs > 0 Then
|
|
ReDim Preserve vAppend(LBound(Array_1D) To lMax + lNbArgs)
|
|
End If
|
|
End If
|
|
For i = 1 To lNbArgs
|
|
vAppend(lMax + i) = pvArgs(i - 1)
|
|
Next i
|
|
|
|
Finally:
|
|
Append = vAppend()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Append
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function AppendColumn(Optional ByRef Array_2D As Variant _
|
|
, Optional ByRef Column As Variant _
|
|
) As Variant
|
|
''' AppendColumn appends to the right side of a 2D array a new Column
|
|
''' Args
|
|
''' Array_2D: the pre-existing array, may be empty
|
|
''' If the array has 1 dimension, it is considered as the 1st Column of the resulting 2D array
|
|
''' Column: a 1D array with as many items as there are rows in Array_2D
|
|
''' Returns:
|
|
''' the new extended array. Its LBounds are identical to that of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINSERTERROR
|
|
''' Examples:
|
|
''' SF_Array.AppendColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 4), (2, 5), (3, 6))
|
|
''' x = SF_Array.AppendColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
|
|
|
|
Dim vAppendColumn As Variant ' Return value
|
|
Dim iDims As Integer ' Dimensions of Array_2D
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim lMin As Long ' LBound of Column array
|
|
Dim lMax As Long ' UBound of Column array
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.AppendColumn"
|
|
Const cstSubArgs = "Array_2D, Column"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vAppendColumn = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
|
|
If Not SF_Utils._ValidateArray(Column, "Column", 1) Then GoTo Finally
|
|
End If
|
|
iDims = SF_Array.CountDims(Array_2D)
|
|
If iDims > 2 Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Column)
|
|
lMax = UBound(Column)
|
|
|
|
' Compute future dimensions of output array
|
|
Select Case iDims
|
|
Case 0 : lMin1 = lMin : lMax1 = lMax
|
|
lMin2 = 0 : lMax2 = -1
|
|
Case 1 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = 0 : lMax2 = 0
|
|
Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
End Select
|
|
If iDims > 0 And lMax - lMin <> lMax1 - lMin1 Then GoTo CatchColumn
|
|
ReDim vAppendColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
|
|
|
|
' Copy input array to output array
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
If iDims = 2 Then vAppendColumn(i, j) = Array_2D(i, j) Else vAppendColumn(i, j) = Array_2D(i)
|
|
Next j
|
|
Next i
|
|
' Copy new Column
|
|
For i = lMin1 To lMax1
|
|
vAppendColumn(i, lMax2 + 1) = Column(i)
|
|
Next i
|
|
|
|
Finally:
|
|
AppendColumn = vAppendColumn()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchColumn:
|
|
SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.AppendColumn
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function AppendRow(Optional ByRef Array_2D As Variant _
|
|
, Optional ByRef Row As Variant _
|
|
) As Variant
|
|
''' AppendRow appends below a 2D array a new row
|
|
''' Args
|
|
''' Array_2D: the pre-existing array, may be empty
|
|
''' If the array has 1 dimension, it is considered as the 1st row of the resulting 2D array
|
|
''' Row: a 1D array with as many items as there are columns in Array_2D
|
|
''' Returns:
|
|
''' the new extended array. Its LBounds are identical to that of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINSERTERROR
|
|
''' Examples:
|
|
''' SF_Array.AppendRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 2, 3), (4, 5, 6))
|
|
''' x = SF_Array.AppendRow(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
|
|
|
|
Dim vAppendRow As Variant ' Return value
|
|
Dim iDims As Integer ' Dimensions of Array_2D
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim lMin As Long ' LBound of row array
|
|
Dim lMax As Long ' UBound of row array
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.AppendRow"
|
|
Const cstSubArgs = "Array_2D, Row"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vAppendRow = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
|
|
If Not SF_Utils._ValidateArray(Row, "Row", 1) Then GoTo Finally
|
|
End If
|
|
iDims = SF_Array.CountDims(Array_2D)
|
|
If iDims > 2 Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Row)
|
|
lMax = UBound(Row)
|
|
|
|
' Compute future dimensions of output array
|
|
Select Case iDims
|
|
Case 0 : lMin1 = 0 : lMax1 = -1
|
|
lMin2 = lMin : lMax2 = lMax
|
|
Case 1 : lMin1 = 0 : lMax1 = 0
|
|
lMin2 = LBound(Array_2D, 1) : lMax2 = UBound(Array_2D, 1)
|
|
Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
End Select
|
|
If iDims > 0 And lMax - lMin <> lMax2 - lMin2 Then GoTo CatchRow
|
|
ReDim vAppendRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
|
|
|
|
' Copy input array to output array
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
If iDims = 2 Then vAppendRow(i, j) = Array_2D(i, j) Else vAppendRow(i, j) = Array_2D(j)
|
|
Next j
|
|
Next i
|
|
' Copy new row
|
|
For j = lMin2 To lMax2
|
|
vAppendRow(lMax1 + 1, j) = Row(j)
|
|
Next j
|
|
|
|
Finally:
|
|
AppendRow = vAppendRow()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchRow:
|
|
SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.AppendRow
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Contains(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal ToFind As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
) As Boolean
|
|
''' Check if a 1D array contains the ToFind number, string or date
|
|
''' The comparison between strings can be done case-sensitive or not
|
|
''' If the array is sorted then
|
|
''' the array must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' a binary search is done
|
|
''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
|
|
''' Args:
|
|
''' Array_1D: the array to scan
|
|
''' ToFind: a number, a date or a string to find
|
|
''' CaseSensitive: Only for string comparisons, default = False
|
|
''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
|
|
''' Return: True when found
|
|
''' Result is unpredictable when array is announced sorted and is in reality not
|
|
''' Examples:
|
|
''' SF_Array.Contains(Array("A","B","c","D"), "C", SortOrder := "ASC") returns True
|
|
''' SF_Array.Contains(Array("A","B","c","D"), "C", CaseSensitive := True) returns False
|
|
|
|
Dim bContains As Boolean ' Return value
|
|
Dim iToFindType As Integer ' VarType of ToFind
|
|
Const cstThisSub = "Array.Contains"
|
|
Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
|
|
bContains = False
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
|
|
iToFindType = SF_Utils._VarTypeExt(ToFind)
|
|
If SortOrder <> "" Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, iToFindType) Then GoTo Finally
|
|
Else
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
bContains = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, UCase(SortOrder))(0)
|
|
|
|
Finally:
|
|
Contains = bContains
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Contains
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ConvertFromDataArray(Optional ByRef DataArray As Variant _
|
|
, Optional ByVal IsRange As Variant _
|
|
, Optional ByVal FillValue As Variant _
|
|
) As Variant
|
|
''' Convert a data array to a scalar, a vector or a 2D array
|
|
''' A "data array" is an array of subarrays. The array and the subarrays must be zero-based.
|
|
''' The individual items may be of any type.
|
|
''' On request, the individual items are reduced to strings or doubles only.
|
|
''' Typically it represents
|
|
''' - the content of a range of Calc cells returned by the UNO XCellRange.getDataArray()
|
|
''' or XCellRange.getFormulaArray() methods
|
|
''' - the output of the SF_Session.ExecuteCalcFunction() method
|
|
''' - a tuple of (sub)tuples returned by a Python script.
|
|
''' Args:
|
|
''' DataArray: an array of subarrays. Array and subarrays must be zero-based.
|
|
''' IsRange: When True (default = False), the items are converted to strings or doubles.
|
|
''' FillValue: Default value of missing items. Default = the empty string
|
|
''' Returns:
|
|
''' A scalar, a zero-based 1D array or a zero-based 2D array.
|
|
''' The number of columns in the resulting 2D array = the number of items in the 1st subarray.
|
|
''' If next subarrays have a different size, next rows can be complemented with FillValue or truncated.
|
|
''' Example:
|
|
''' vDataArray = Array(Array("Col1", "Col2", "Col3"), Array(10, 20, 30))
|
|
''' Array2D = SF_Array.ConvertFromDataArray(vDataArray)
|
|
''' MsgBox Array2D(1, 2) ' 30
|
|
|
|
Dim vArray As Variant ' Return value
|
|
Dim lMax1 As Long ' UBound of DataArray
|
|
Dim lMax2 As Long ' UBound of the 1st row of DataArray
|
|
Dim lMax As Long ' UBound of a subarray
|
|
Dim i As Long
|
|
Dim j As Long
|
|
|
|
Const cstThisSub = "Array.ConvertFromDataArray"
|
|
Const cstSubArgs = "DataArray, [IsRange=False], [FillValue=""""]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vArray = Array()
|
|
|
|
Check:
|
|
If IsMissing(IsRange) Or IsEmpty(IsRange) Then IsRange = False
|
|
If IsMissing(FillValue) Or IsEmpty(FillValue) Then FillValue = ""
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(DataArray, "DataArray", 1) Then GoTo Finally
|
|
For i = 0 To UBound(DataArray)
|
|
If Not SF_Utils._ValidateArray(DataArray(i), "DataArray(" & i & ")", 1) Then GoTo Finally
|
|
Next i
|
|
End If
|
|
|
|
Try:
|
|
' Convert the data array to scalar, vector or array
|
|
lMax1 = UBound(DataArray)
|
|
If lMax1 >= 0 Then
|
|
lMax2 = UBound(DataArray(0))
|
|
If lMax2 >= 0 Then
|
|
If lMax1 + lMax2 > 0 Then vArray = Array()
|
|
Select Case True
|
|
Case lMax1 = 0 And lMax2 = 0 ' Scalar
|
|
vArray = _ConvertToCellValue(DataArray(0)(0), pbIsCell := IsRange)
|
|
Case lMax1 > 0 And lMax2 = 0 ' Vertical vector
|
|
ReDim vArray(0 To lMax1)
|
|
For i = 0 To lMax1
|
|
vArray(i) = _ConvertToCellValue(DataArray(i)(0), pbIsCell := IsRange)
|
|
Next i
|
|
Case lMax1 = 0 And lMax2 > 0 ' Horizontal vector
|
|
ReDim vArray(0 To lMax2)
|
|
For j = 0 To lMax2
|
|
vArray(j) = _ConvertToCellValue(DataArray(0)(j), pbIsCell := IsRange)
|
|
Next j
|
|
Case Else ' Array
|
|
ReDim vArray(0 To lMax1, 0 To lMax2)
|
|
For i = 0 To lMax1
|
|
lMax = UBound(DataArray(i))
|
|
For j = 0 To lMax2
|
|
If j <= lMax Then vArray(i, j) = _ConvertToCellValue(DataArray(i)(j), pbIsCell := IsRange) Else vArray(i, j) = FillValue
|
|
Next j
|
|
Next i
|
|
End Select
|
|
End If
|
|
End If
|
|
|
|
Finally:
|
|
ConvertFromDataArray = vArray
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ConvertFromDataArray
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ConvertToDataArray(Optional ByRef Data As Variant _
|
|
, Optional ByVal IsRange As Variant _
|
|
, Optional ByVal Rows As Variant _
|
|
, Optional ByVal Columns As Variant _
|
|
) As Variant
|
|
''' Create a data array from a scalar, a 1D array or a 2D array
|
|
''' The returned "data array" is an array of subarrays.
|
|
''' On request, the individual items are reduced to strings or doubles only.
|
|
''' Typically it represents
|
|
''' - the content of a range of Calc cells used to apply the UNO XCellRange.setDataArray()
|
|
''' or XCellRange.setFormulaArray() methods
|
|
''' - a tuple of (sub)tuples passed to a Python script.
|
|
''' Input argument may already be a data array, typically when call is issued by a Python script.
|
|
''' When IsRange = True then the individual items are converted to (possibly empty) strings or doubles.
|
|
''' Args:
|
|
''' Data: the input scalar or array. If array, must be 1D or 2D otherwise it is ignored.
|
|
''' IsRange: When True (default = False), the items are converted to strings or doubles.
|
|
''' Rows, Columns: the number of rows or columns of the returned data array.
|
|
''' If bigger than Data, fill with zero-length strings
|
|
''' If smaller than Data, truncate
|
|
''' If Rows = 1 and the input array is a vector, the data array is aligned horizontally
|
|
''' By default, vectors are aligned vertically.
|
|
''' When absent, the size of the output is determined by the input array.
|
|
''' Returns:
|
|
''' The output is always an array of nested arrays. Array and nested arrays are zero-based.
|
|
''' It is compatible with the XCellRange.DataArray property when IsRange = True.
|
|
|
|
Dim vDataArray() As Variant ' Return value
|
|
Dim vVector() As Variant ' A temporary 1D array
|
|
Dim vItem As Variant ' A single input item
|
|
Dim iDims As Integer ' Number of dimensions of the input argument
|
|
Dim lMin1 As Long ' Lower bound (1) of input array
|
|
Dim lMax1 As Long ' Upper bound (1)
|
|
Dim lMin2 As Long ' Lower bound (2)
|
|
Dim lMax2 As Long ' Upper bound (2)
|
|
Dim lRows As Long ' Upper bound of vDataArray
|
|
Dim lCols As Long ' Upper bound of vVector
|
|
Dim bHorizontal As Boolean ' Horizontal vectoriDims <> 0 => Data has at least 1 item
|
|
Dim bDataArray As Boolean ' Input array is already an array of arrays
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstEmpty = "" ' Empty cell
|
|
|
|
Const cstThisSub = "Array.ConvertToDataArray"
|
|
Const cstSubArgs = "Data, [IsRange=False], [Rows=0], [Columns=0]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vDataArray = Array()
|
|
|
|
Check:
|
|
If IsMissing(IsRange) Or IsEmpty(IsRange) Then IsRange = False
|
|
If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0
|
|
If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(IsRange, "IsRange", V_BOOLEAN) Then GoTo Finally
|
|
If Not SF_Utils._Validate(Rows, "Rows", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(Columns, "Columns", V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
' Examine the input argument and determine its boundaries
|
|
' Set the output dimensions accordingly
|
|
iDims = SF_Array.CountDims(Data)
|
|
If iDims = 0 Or iDims > 2 Then Exit Function
|
|
lMin1 = 0 : lMax1 = 0 ' Default values
|
|
lMin2 = 0 : lMax2 = 0
|
|
lRows = 0 : lCols = 0
|
|
Select Case iDims
|
|
Case -1 ' Scalar value
|
|
Case 1 ' 1D Array
|
|
bHorizontal = ( Rows = 1 )
|
|
bDataArray = IsArray(Data(LBound(Data)))
|
|
If Not bDataArray Then
|
|
If Not bHorizontal Then
|
|
lMin1 = LBound(Data) : lMax1 = UBound(Data)
|
|
lRows = lMax1 - lMin1
|
|
Else
|
|
lMin2 = LBound(Data) : lMax2 = UBound(Data)
|
|
lCols = lMax2 - lMin2
|
|
End If
|
|
Else
|
|
iDims = 2
|
|
lMin1 = LBound(Data) : lMax1 = UBound(Data)
|
|
lMin2 = LBound(Data(0)) : lMax2 = UBound(Data(0))
|
|
lRows = lMax1 - lMin1
|
|
lCols = lMax2 - lMin2
|
|
End If
|
|
Case 2 ' 2D Array
|
|
lMin1 = LBound(Data, 1) : lMax1 = UBound(Data, 1)
|
|
lMin2 = LBound(Data, 2) : lMax2 = UBound(Data, 2)
|
|
lRows = lMax1 - lMin1
|
|
lCols = lMax2 - lMin2
|
|
End Select
|
|
|
|
' Size the future data array to the output dimensions
|
|
' Are the dimensions imposed ?
|
|
If Rows >= 1 Then lRows = Rows - 1
|
|
If Columns >= 1 Then lCols = Columns - 1
|
|
ReDim vDataArray(0 To lRows)
|
|
|
|
' Feed the output array row by row, each row being a vector
|
|
For i = 0 To lRows
|
|
ReDim vVector(0 To lCols)
|
|
For j = 0 To lCols
|
|
If i > lMax1 - lMin1 Then
|
|
vVector(j) = cstEmpty
|
|
ElseIf j > lMax2 - lMin2 Then
|
|
vVector(j) = cstEmpty
|
|
Else
|
|
Select Case iDims
|
|
Case -1 : vItem = _ConvertToCellValue(Data, IsRange)
|
|
Case 1
|
|
If bHorizontal Then
|
|
vItem = _ConvertToCellValue(Data(j + lMin2), IsRange)
|
|
Else
|
|
vItem = _ConvertToCellValue(Data(i + lMin1), IsRange)
|
|
End If
|
|
Case 2
|
|
If bDataArray Then
|
|
vItem = _ConvertToCellValue(Data(i + lMin1)(j + lMin2), IsRange)
|
|
Else
|
|
vItem = _ConvertToCellValue(Data(i + lMin1, j + lMin2), IsRange)
|
|
End If
|
|
End Select
|
|
vVector(j) = vItem
|
|
End If
|
|
vDataArray(i) = vVector
|
|
Next j
|
|
Next i
|
|
|
|
Finally:
|
|
ConvertToDataArray = vDataArray
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ConvertToDataArray
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ConvertToDictionary(Optional ByRef Array_2D As Variant) As Variant
|
|
''' Store the content of a 2-columns array into a dictionary with case-sensitive comparison of keys
|
|
''' Key found in 1st column, Item found in 2nd
|
|
''' Args:
|
|
''' Array_2D: 1st column must contain exclusively non zero-length strings
|
|
''' 1st column may not be sorted
|
|
''' Returns:
|
|
''' a ScriptForge dictionary object
|
|
''' Examples:
|
|
'''
|
|
|
|
Dim oDict As Variant ' Return value
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.ConvertToDictionary"
|
|
Const cstSubArgs = "Array_2D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2, V_STRING, True) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
Set oDict = SF_Services.CreateScriptService("Dictionary", True)
|
|
For i = LBound(Array_2D, 1) To UBound(Array_2D, 1)
|
|
oDict.Add(Array_2D(i, 0), Array_2D(i, 1))
|
|
Next i
|
|
|
|
ConvertToDictionary = oDict
|
|
|
|
Finally:
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ConvertToDictionary
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ConvertToRange(Optional ByRef Data As Variant _
|
|
, Optional ByVal Direction As Variant _
|
|
) As Variant
|
|
''' Create a valid cells range content from a scalar, a 1D array, a 2D array or a data array
|
|
''' (a "data array" is an array of subarrays). Lower bounds are preserved.
|
|
''' The individual items are always reduced to strings or doubles. Including booleans or dates.
|
|
''' The returned scalar or array is a valid argument of the SF_Session.ExecuteCalcFunction() method.
|
|
''' Input argument may be a data array, typically when returned by a Python script.
|
|
''' Args:
|
|
''' Data: the input scalar, array or data array. If array, must be 1D or 2D, otherwise 0 is returned.
|
|
''' Direction: the alignment of the range when it is a vector, either "V"[ertical, default] or "H"[orizontal].
|
|
''' Returns:
|
|
''' A scalar or a 2D array compatible with the format of the arguments expected by
|
|
''' - the SF_Session.ExecuteCalcFunction() method, in the context of [complex] array functions
|
|
''' - a Calc user-defined function when called by a macro
|
|
''' Example:
|
|
''' arr = CreateScriptService("Array")
|
|
''' sess = CreateScriptService("Session")
|
|
''' matrix = Array(Array(-1, 2, 3), Array(4, -5, 6), Array(7, 8, -9)) ' Input = a data array
|
|
''' result = sess.ExecuteCalcFunction("ABS", arr.ConvertToRange(matrix))
|
|
''' ' result is a data array; result(2)(2) = 9
|
|
|
|
Dim vRange As Variant ' Return value
|
|
Dim iDims As Integer ' Number of dimensions of Data
|
|
Dim vDataArray As Variant ' External array of a data array
|
|
Dim vVector As Variant ' Internal array of a data array
|
|
Dim lMin1 As Long ' Lower bound #1
|
|
Dim lMax1 As Long ' Upper bound #1
|
|
Dim lMin2 As Long ' Lower bound #2
|
|
Dim lMax2 As Long ' Upper bound #2
|
|
Dim lMin As Long ' Lower bound
|
|
Dim lMax As Long ' Upper bound
|
|
Dim i As Long
|
|
Dim j As Long
|
|
|
|
Const cstThisSub = "Array.ConvertToRange"
|
|
Const cstSubArgs = "Data, [Direction=""""|""V""|""H""]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vRange = 0
|
|
|
|
Check:
|
|
If IsMissing(Direction) Or IsEmpty(Direction) Then Direction = "V"
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If IsMissing(Data) Or IsEmpty(Data) Then
|
|
If Not SF_Utils._Validate(Data, "Data") Then GoTo Finally
|
|
End If
|
|
If Not SF_Utils._Validate(Direction, "Direction", V_STRING, Array("", "V", "H")) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
iDims = SF_Array.CountDims(Data)
|
|
If iDims = 0 Or iDims > 2 Then Exit Function
|
|
|
|
Select Case iDims
|
|
' All input items are converted on-the-fly to an acceptable Calc cell value
|
|
Case -1 ' Scalar
|
|
vRange = _ConvertToCellValue(Data, pbIsCell := True)
|
|
Case 1 ' Vector or data array
|
|
' iDims <> 0 => Data has at least 1 item
|
|
lMin1 = LBound(Data) : lMax1 = UBound(Data)
|
|
If IsArray(Data(lMin1)) Then ' Data array
|
|
' Design a 2D array of the appropriate size
|
|
lMin2 = LBound(Data(lMin1)) : lMax2 = UBound(Data(lMin1))
|
|
vRange = Array()
|
|
ReDim vRange(lMin1 To lMax1, lMin2 To lMax2)
|
|
For i = lMin1 To lMax1
|
|
If Not IsArray(Data(i)) Then
|
|
lMin = -1 : lMax = -1
|
|
Else
|
|
lMin = LBound(Data(i))
|
|
lMax = UBound(Data(i))
|
|
End If
|
|
For j = lMin2 To lMax2
|
|
If j < lMin Or j > lMax Then vRange(i, j) = "" Else vRange(i, j) = _ConvertToCellValue(Data(i)(j), pbIsCell := True)
|
|
Next j
|
|
Next i
|
|
Else ' Vector
|
|
vRange = Array()
|
|
If UCase(Direction) = "V" Then ' Vertical
|
|
ReDim vRange(lMin1 To lMax1, 0 To 0)
|
|
For i = lMin1 To lMax1
|
|
vRange(i, 0) = _ConvertToCellValue(Data(i), pbIsCell := True)
|
|
Next i
|
|
Else ' Horizontal
|
|
ReDim vRange(0 To 0, lMin1 To lMax1)
|
|
For j = lMin1 To lMax1
|
|
vRange(0, j) = _ConvertToCellValue(Data(j), pbIsCell := True)
|
|
Next j
|
|
End If
|
|
End If
|
|
Case 2
|
|
' Copy all array items
|
|
vRange = Array()
|
|
lMin1 = LBound(Data, 1) : lMax1 = UBound(Data, 1)
|
|
lMin2 = LBound(Data, 2) : lMax2 = UBound(Data, 2)
|
|
ReDim vRange(lMin1 To lMax1, lMin2 To lMax2)
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
vRange(i, j) = _ConvertToCellValue(Data(i, j), pbIsCell := True)
|
|
Next j
|
|
Next i
|
|
Case Else
|
|
End Select
|
|
|
|
Finally:
|
|
ConvertToRange = vRange
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ConvertToRange
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Copy(Optional ByRef Array_ND As Variant) As Variant
|
|
''' Duplicate a 1D or 2D array
|
|
''' A usual assignment copies an array by reference, i.e. shares the same memory location
|
|
''' Dim a, b
|
|
''' a = Array(1, 2, 3)
|
|
''' b = a
|
|
''' a(2) = 30
|
|
''' MsgBox b(2) ' 30
|
|
''' Args
|
|
''' Array_ND: the array to copy, may be empty
|
|
''' Return:
|
|
''' the copied array. Subarrays however still remain assigned by reference
|
|
''' Examples:
|
|
''' SF_Array.Copy(Array(1, 2, 3)) returns (1, 2, 3)
|
|
|
|
Dim vCopy As Variant ' Return value
|
|
Dim iDims As Integer ' Number of dimensions of the input array
|
|
Const cstThisSub = "Array.Copy"
|
|
Const cstSubArgs = "Array_ND"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vCopy = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_ND, "Array_ND") Then GoTo Finally
|
|
iDims = SF_Array.CountDims(Array_ND)
|
|
If iDims > 2 Then
|
|
If Not SF_Utils._ValidateArray(Array_ND, "Array_ND", 2) Then GoTo Finally
|
|
End If
|
|
End If
|
|
|
|
Try:
|
|
Select Case iDims
|
|
Case 0
|
|
Case 1
|
|
vCopy = Array_ND
|
|
ReDim Preserve vCopy(LBound(Array_ND) To UBound(Array_ND))
|
|
Case 2
|
|
vCopy = Array_ND
|
|
ReDim Preserve vCopy(LBound(Array_ND, 1) To UBound(Array_ND, 1), LBound(Array_ND, 2) To UBound(Array_ND, 2))
|
|
End Select
|
|
|
|
Finally:
|
|
Copy = vCopy()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Copy
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function CountDims(Optional ByRef Array_ND As Variant) As Integer
|
|
''' Count the number of dimensions of an array - may be > 2
|
|
''' Args:
|
|
''' Array_ND: the array to be examined
|
|
''' Return: the number of dimensions: -1 = not array, 0 = uninitialized array, else >= 1
|
|
''' Examples:
|
|
''' Dim a(1 To 10, -3 To 12, 5)
|
|
''' CountDims(a) returns 3
|
|
|
|
Dim iDims As Integer ' Return value
|
|
Dim lMax As Long ' Storage for UBound of each dimension
|
|
Const cstThisSub = "Array.CountDims"
|
|
Const cstSubArgs = "Array_ND"
|
|
|
|
Check:
|
|
iDims = -1
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If IsMissing(Array_ND) Then ' To have missing exception processed
|
|
If Not SF_Utils._ValidateArray(Array_ND, "Array_ND") Then GoTo Finally
|
|
End If
|
|
End If
|
|
|
|
Try:
|
|
On Local Error Goto ErrHandler
|
|
' Loop, increasing the dimension index (i) until an error occurs.
|
|
' An error will occur when i exceeds the number of dimensions in the array. Returns i - 1.
|
|
iDims = 0
|
|
If Not IsArray(Array_ND) Then
|
|
Else
|
|
Do
|
|
iDims = iDims + 1
|
|
lMax = UBound(Array_ND, iDims)
|
|
Loop Until (Err <> 0)
|
|
End If
|
|
|
|
ErrHandler:
|
|
On Local Error GoTo 0
|
|
|
|
iDims = iDims - 1
|
|
If iDims = 1 Then
|
|
If LBound(Array_ND, 1) > UBound(Array_ND, 1) Then iDims = 0
|
|
End If
|
|
|
|
Finally:
|
|
CountDims = iDims
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
End Function ' ScriptForge.SF_Array.CountDims
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Difference(Optional ByRef Array1_1D As Variant _
|
|
, Optional ByRef Array2_1D As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Build a set being the Difference of the two input arrays, i.e. items are contained in 1st array and NOT in 2nd
|
|
''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' The comparison between strings is case sensitive or not
|
|
''' Args:
|
|
''' Array1_1D: a 1st input array
|
|
''' Array2_1D: a 2nd input array
|
|
''' CaseSensitive: default = False
|
|
''' Returns: a zero-based array containing unique items from the 1st array not present in the 2nd
|
|
''' The output array is sorted in ascending order
|
|
''' Examples:
|
|
''' SF_Array.Difference(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B")
|
|
|
|
Dim vDifference() As Variant ' Return value
|
|
Dim vSorted() As Variant ' The 2nd input array after sort
|
|
Dim iType As Integer ' VarType of elements in input arrays
|
|
Dim lMin1 As Long ' LBound of 1st input array
|
|
Dim lMax1 As Long ' UBound of 1st input array
|
|
Dim lMin2 As Long ' LBound of 2nd input array
|
|
Dim lMax2 As Long ' UBound of 2nd input array
|
|
Dim lSize As Long ' Number of Difference items
|
|
Dim vItem As Variant ' One single item in the array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Difference"
|
|
Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vDifference = Array()
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally
|
|
iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
|
|
If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
|
|
lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
|
|
|
|
' If 1st array is empty, do nothing
|
|
If lMax1 < lMin1 Then
|
|
ElseIf lMax2 < lMin2 Then ' only 2nd array is empty
|
|
vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
|
|
Else
|
|
|
|
' First sort the 2nd array
|
|
vSorted = SF_Array.Sort(Array2_1D, "ASC", CaseSensitive)
|
|
|
|
' Resize the output array to the size of the 1st array
|
|
ReDim vDifference(0 To (lMax1 - lMin1))
|
|
lSize = -1
|
|
|
|
' Fill vDifference one by one with items present only in 1st set
|
|
For i = lMin1 To lMax1
|
|
vItem = Array1_1D(i)
|
|
If Not SF_Array.Contains(vSorted, vItem, CaseSensitive, "ASC") Then
|
|
lSize = lSize + 1
|
|
vDifference(lSize) = vItem
|
|
End If
|
|
Next i
|
|
|
|
' Remove unfilled entries and duplicates
|
|
If lSize >= 0 Then
|
|
ReDim Preserve vDifference(0 To lSize)
|
|
vDifference() = SF_Array.Unique(vDifference, CaseSensitive)
|
|
Else
|
|
vDifference = Array()
|
|
End If
|
|
End If
|
|
|
|
Finally:
|
|
Difference = vDifference()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Difference
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ExportToTextFile(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal FileName As Variant _
|
|
, Optional ByVal Encoding As Variant _
|
|
) As Boolean
|
|
''' Write all items of the array sequentially to a text file
|
|
''' If the file exists already, it will be overwritten without warning
|
|
''' Args:
|
|
''' Array_1D: the array to export
|
|
''' FileName: the full name (path + file) in SF_FileSystem.FileNaming notation
|
|
''' Encoding: The character set that should be used
|
|
''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml
|
|
''' Note that LibreOffice does not implement all existing sets
|
|
''' Default = UTF-8
|
|
''' Returns:
|
|
''' True if successful
|
|
''' Examples:
|
|
''' SF_Array.ExportToTextFile(Array("A","B","C","D"), "C:\Temp\A short file.txt")
|
|
|
|
Dim bExport As Boolean ' Return value
|
|
Dim oFile As Object ' Output file handler
|
|
Dim sLine As String ' A single line
|
|
Const cstThisSub = "Array.ExportToTextFile"
|
|
Const cstSubArgs = "Array_1D, FileName"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
bExport = False
|
|
|
|
Check:
|
|
If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding = "UTF-8"
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, V_STRING, True) Then GoTo Finally
|
|
If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally
|
|
If Not SF_Utils._Validate(Encoding, "Encoding", V_STRING) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True, Encoding := Encoding)
|
|
If Not IsNull(oFile) Then
|
|
With oFile
|
|
For Each sLine In Array_1D
|
|
.WriteLine(sLine)
|
|
Next sLine
|
|
.CloseFile()
|
|
End With
|
|
End If
|
|
|
|
bExport = True
|
|
|
|
Finally:
|
|
If Not IsNull(oFile) Then Set oFile = oFile.Dispose()
|
|
ExportToTextFile = bExport
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ExportToTextFile
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ExtractColumn(Optional ByRef Array_2D As Variant _
|
|
, Optional ByVal ColumnIndex As Variant _
|
|
) As Variant
|
|
''' ExtractColumn extracts from a 2D array a specific column
|
|
''' Args
|
|
''' Array_2D: the array from which to extract
|
|
''' ColumnIndex: the column to extract - must be in the interval [LBound, UBound]
|
|
''' Returns:
|
|
''' the extracted column. Its LBound and UBound are identical to that of the 1st dimension of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINDEX1ERROR
|
|
''' Examples:
|
|
''' |1, 2, 3|
|
|
''' SF_Array.ExtractColumn( |4, 5, 6|, 2) returns (3, 6, 9)
|
|
''' |7, 8, 9|
|
|
|
|
Dim vExtractColumn As Variant ' Return value
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound1 of input array
|
|
Dim lMax2 As Long ' UBound1 of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.ExtractColumn"
|
|
Const cstSubArgs = "Array_2D, ColumnIndex"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vExtractColumn = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ColumnIndex, "ColumnIndex", V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
' Compute future dimensions of output array
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
If ColumnIndex < lMin2 Or ColumnIndex > lMax2 Then GoTo CatchIndex
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
ReDim vExtractColumn(lMin1 To lMax1)
|
|
|
|
' Copy Column of input array to output array
|
|
For i = lMin1 To lMax1
|
|
vExtractColumn(i) = Array_2D(i, ColumnIndex)
|
|
Next i
|
|
|
|
Finally:
|
|
ExtractColumn = vExtractColumn()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchIndex:
|
|
SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "ColumnIndex", SF_Array._Repr(Array_2D), ColumnIndex)
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ExtractColumn
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ExtractRow(Optional ByRef Array_2D As Variant _
|
|
, Optional ByVal RowIndex As Variant _
|
|
) As Variant
|
|
''' ExtractRow extracts from a 2D array a specific row
|
|
''' Args
|
|
''' Array_2D: the array from which to extract
|
|
''' RowIndex: the row to extract - must be in the interval [LBound, UBound]
|
|
''' Returns:
|
|
''' the extracted row. Its LBound and UBound are identical to that of the 2nd dimension of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINDEX1ERROR
|
|
''' Examples:
|
|
''' |1, 2, 3|
|
|
''' SF_Array.ExtractRow(|4, 5, 6|, 2) returns (7, 8, 9)
|
|
''' |7, 8, 9|
|
|
|
|
Dim vExtractRow As Variant ' Return value
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound1 of input array
|
|
Dim lMax2 As Long ' UBound1 of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.ExtractRow"
|
|
Const cstSubArgs = "Array_2D, RowIndex"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vExtractRow = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
If Not SF_Utils._Validate(RowIndex, "RowIndex", V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
' Compute future dimensions of output array
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
If RowIndex < lMin1 Or RowIndex > lMax1 Then GoTo CatchIndex
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
ReDim vExtractRow(lMin2 To lMax2)
|
|
|
|
' Copy row of input array to output array
|
|
For i = lMin2 To lMax2
|
|
vExtractRow(i) = Array_2D(RowIndex, i)
|
|
Next i
|
|
|
|
Finally:
|
|
ExtractRow = vExtractRow()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchIndex:
|
|
SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "RowIndex", SF_Array._Repr(Array_2D), RowIndex)
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ExtractRow
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Flatten(Optional ByRef Array_1D As Variant) As Variant
|
|
''' Stack all items and all items in subarrays into one array without subarrays
|
|
''' Args
|
|
''' Array_1D: the pre-existing array, may be empty
|
|
''' Return:
|
|
''' The new flattened array. Its LBound is identical to that of Array_1D
|
|
''' If one of the subarrays has a number of dimensions > 1 Then that subarray is left unchanged
|
|
''' Examples:
|
|
''' SF_Array.Flatten(Array(1, 2, Array(3, 4, 5)) returns (1, 2, 3, 4, 5)
|
|
|
|
Dim vFlatten As Variant ' Return value
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim lIndex As Long ' Index in output array
|
|
Dim vItem As Variant ' Array single item
|
|
Dim iDims As Integer ' Array number of dimensions
|
|
Dim lEmpty As Long ' Number of empty subarrays
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.Flatten"
|
|
Const cstSubArgs = "Array_1D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vFlatten = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
If UBound(Array_1D) >= LBound(Array_1D) Then
|
|
lMin = LBound(Array_1D) : lMax = UBound(Array_1D)
|
|
ReDim vFlatten(lMin To lMax) ' Initial minimal sizing
|
|
lEmpty = 0
|
|
lIndex = lMin - 1
|
|
For i = lMin To lMax
|
|
vItem = Array_1D(i)
|
|
If IsArray(vItem) Then
|
|
iDims = SF_Array.CountDims(vItem)
|
|
Select Case iDims
|
|
Case 0 ' Empty arrays are ignored
|
|
lEmpty = lEmpty + 1
|
|
Case 1 ' Only 1D subarrays are flattened
|
|
ReDim Preserve vFlatten(lMin To UBound(vFlatten) + UBound(vItem) - LBound(vItem))
|
|
For j = LBound(vItem) To UBound(vItem)
|
|
lIndex = lIndex + 1
|
|
vFlatten(lIndex) = vItem(j)
|
|
Next j
|
|
Case > 1 ' Other arrays are left unchanged
|
|
lIndex = lIndex + 1
|
|
vFlatten(lIndex) = vItem
|
|
End Select
|
|
Else
|
|
lIndex = lIndex + 1
|
|
vFlatten(lIndex) = vItem
|
|
End If
|
|
Next i
|
|
End If
|
|
' Reduce size of output if Array_1D is populated with some empty arrays
|
|
If lEmpty > 0 Then
|
|
If lIndex - lEmpty < lMin Then
|
|
vFlatten = Array()
|
|
Else
|
|
ReDim Preserve vFlatten(lMin To UBound(vFlatten) - lEmpty)
|
|
End If
|
|
End If
|
|
|
|
Finally:
|
|
Flatten = vFlatten()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Flatten
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
|
|
''' Return the actual value of the given property
|
|
''' Args:
|
|
''' PropertyName: the name of the property as a string
|
|
''' Returns:
|
|
''' The actual value of the property
|
|
''' Exceptions
|
|
''' ARGUMENTERROR The property does not exist
|
|
|
|
Const cstThisSub = "Array.GetProperty"
|
|
Const cstSubArgs = "PropertyName"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
GetProperty = Null
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
|
|
End If
|
|
|
|
Try:
|
|
Select Case UCase(PropertyName)
|
|
Case Else
|
|
End Select
|
|
|
|
Finally:
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.GetProperty
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function ImportFromCSVFile(Optional ByRef FileName As Variant _
|
|
, Optional ByVal Delimiter As Variant _
|
|
, Optional ByVal DateFormat As Variant _
|
|
) As Variant
|
|
''' Import the data contained in a comma-separated values (CSV) file
|
|
''' The comma may be replaced by any character
|
|
''' Each line in the file contains a full record
|
|
''' Line splitting is not allowed)
|
|
''' However sequences like \n, \t, ... are left unchanged. Use SF_String.Unescape() to manage them
|
|
''' A special mechanism is implemented to load dates
|
|
''' The applicable CSV format is described in https://tools.ietf.org/html/rfc4180
|
|
''' Args:
|
|
''' FileName: the name of the text file containing the data expressed as given by the current FileNaming
|
|
''' property of the SF_FileSystem service. Default = both URL format or native format
|
|
''' Delimiter: Default = ",". Other usual options are ";" and the tab character
|
|
''' DateFormat: either YYYY-MM-DD, DD-MM-YYYY or MM-DD-YYYY
|
|
''' The dash (-) may be replaced by a dot (.), a slash (/) or a space
|
|
''' Other date formats will be ignored
|
|
''' If "" (default), dates will be considered as strings
|
|
''' Returns:
|
|
''' A 2D-array with each row corresponding with a single record read in the file
|
|
''' and each column corresponding with a field of the record
|
|
''' No check is made about the coherence of the field types across columns
|
|
''' A best guess will be made to identify numeric and date types
|
|
''' If a line contains less or more fields than the first line in the file,
|
|
''' an exception will be raised. Empty lines however are simply ignored
|
|
''' If the size of the file exceeds the number of items limit, a warning is raised
|
|
''' and the array is truncated
|
|
''' Exceptions:
|
|
''' CSVPARSINGERROR Given file is not formatted as a csv file
|
|
''' CSVOVERFLOWWARNING Maximum number of allowed items exceeded
|
|
|
|
Dim vArray As Variant ' Returned array
|
|
Dim lCol As Long ' Index of last column of vArray
|
|
Dim lRow As Long ' Index of current row of vArray
|
|
Dim lFileSize As Long ' Number of records found in the file
|
|
Dim vCsv As Object ' CSV file handler
|
|
Dim sLine As String ' Last read line
|
|
Dim vLine As Variant ' Array of fields of last read line
|
|
Dim sItem As String ' Individual item in the file
|
|
Dim vItem As Variant ' Individual item in the output array
|
|
Dim iPosition As Integer ' Date position in individual item
|
|
Dim iYear As Integer, iMonth As Integer, iDay As Integer
|
|
' Date components
|
|
Dim bIsoDate As Boolean ' When True, do not convert dates to Date variables
|
|
Dim i As Long
|
|
|
|
Const cstItemsLimit = 250000 ' Maximum number of admitted items
|
|
Const cstThisSub = "Array.ImportFromCSVFile"
|
|
Const cstSubArgs = "FileName, [Delimiter="",""], [DateFormat=""""]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vArray = Array()
|
|
|
|
Check:
|
|
If IsMissing(Delimiter) Or IsEmpty(Delimiter) Then Delimiter = ","
|
|
If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat = ""
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally
|
|
If Not SF_Utils._Validate(Delimiter, "Delimiter", V_STRING) Then GoTo Finally
|
|
If Not SF_Utils._Validate(DateFormat, "DateFormat", V_STRING) Then GoTo Finally
|
|
End If
|
|
If Len(Delimiter) = 0 Then Delimiter = ","
|
|
|
|
Try:
|
|
bIsoDate = _SF_.TriggeredByPython ' Dates are not converted
|
|
' Counts the lines present in the file to size the final array
|
|
' Very beneficial for large files, better than multiple ReDims
|
|
' Small overhead for small files
|
|
lFileSize = SF_FileSystem._CountTextLines(FileName, False)
|
|
If lFileSize <= 0 Then GoTo Finally
|
|
|
|
' Reread file line by line
|
|
Set vCsv = SF_FileSystem.OpenTextFile(FileName, IOMode := SF_FileSystem.ForReading)
|
|
If IsNull(vCsv) Then GoTo Finally ' Open error
|
|
lRow = -1
|
|
With vCsv
|
|
Do While Not .AtEndOfStream
|
|
sLine = .ReadLine()
|
|
If Len(sLine) > 0 Then ' Ignore empty lines
|
|
If InStr(sLine, """") > 0 Then vLine = SF_String.SplitNotQuoted(sLine, Delimiter) Else vLine = Split(sLine, Delimiter) ' Simple split when relevant
|
|
lRow = lRow + 1
|
|
If lRow = 0 Then ' Initial sizing of output array
|
|
lCol = UBound(vLine)
|
|
ReDim vArray(0 To lFileSize - 1, 0 To lCol)
|
|
ElseIf UBound(vLine) <> lCol Then
|
|
GoTo CatchCSVFormat
|
|
End If
|
|
' Check type and copy all items of the line
|
|
For i = 0 To lCol
|
|
If Left(vLine(i), 1) = """" Then sItem = SF_String.Unquote(vLine(i)) Else sItem = vLine(i) ' Unquote only when useful
|
|
' Interpret the individual line item
|
|
Select Case True
|
|
Case IsNumeric(sItem)
|
|
If InStr(sItem, ".") + InStr(1, sItem, "e", 1) > 0 Then vItem = Val(sItem) Else vItem = CLng(sItem)
|
|
Case DateFormat <> "" And Len(sItem) = Len(DateFormat)
|
|
If SF_String.IsADate(sItem, DateFormat) Then
|
|
iPosition = InStr(DateFormat, "YYYY") : iYear = CInt(Mid(sItem, iPosition, 4))
|
|
iPosition = InStr(DateFormat, "MM") : iMonth = CInt(Mid(sItem, iPosition, 2))
|
|
iPosition = InStr(DateFormat, "DD") : iDay = CInt(Mid(sItem, iPosition, 2))
|
|
vItem = DateSerial(iYear, iMonth, iDay)
|
|
If bIsoDate Then vItem = SF_Utils._CDateToIso(vItem) ' Called from Python
|
|
Else
|
|
vItem = sItem
|
|
End If
|
|
Case Else : vItem = sItem
|
|
End Select
|
|
vArray(lRow, i) = vItem
|
|
Next i
|
|
End If
|
|
' Provision to avoid very large arrays and their sometimes erratic behaviour
|
|
If (lRow + 2) * (lCol + 1) > cstItemsLimit Then
|
|
ReDim Preserve vArray(0 To lRow, 0 To lCol)
|
|
GoTo CatchOverflow
|
|
End If
|
|
Loop
|
|
End With
|
|
|
|
Finally:
|
|
If Not IsNull(vCsv) Then
|
|
vCsv.CloseFile()
|
|
Set vCsv = vCsv.Dispose()
|
|
End If
|
|
ImportFromCSVFile = vArray
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchCSVFormat:
|
|
SF_Exception.RaiseFatal(CSVPARSINGERROR, FileName, vCsv.Line, sLine)
|
|
GoTo Finally
|
|
CatchOverflow:
|
|
'TODO SF_Exception.RaiseWarning(SF_Exception.CSVOVERFLOWWARNING, cstThisSub)
|
|
'MsgBox "TOO MUCH LINES !!"
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.ImportFromCSVFile
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function IndexOf(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal ToFind As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
) As Long
|
|
''' Finds in a 1D array the ToFind number, string or date
|
|
''' ToFind must exist within the array.
|
|
''' The comparison between strings can be done case-sensitively or not
|
|
''' If the array is sorted then
|
|
''' the array must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' a binary search is done
|
|
''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
|
|
''' Args:
|
|
''' Array_1D: the array to scan
|
|
''' ToFind: a number, a date or a string to find
|
|
''' CaseSensitive: Only for string comparisons, default = False
|
|
''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
|
|
''' Return: the index of the found item, LBound - 1 if not found
|
|
''' Result is unpredictable when array is announced sorted and is in reality not
|
|
''' Examples:
|
|
''' SF_Array.IndexOf(Array("A","B","c","D"), "C", SortOrder := "ASC") returns 2
|
|
''' SF_Array.IndexOf(Array("A","B","c","D"), "C", CaseSensitive := True) returns -1
|
|
|
|
Dim vFindItem As Variant ' 2-items array (0) = True if found, (1) = Index where found
|
|
Dim lIndex As Long ' Return value
|
|
Dim iToFindType As Integer ' VarType of ToFind
|
|
Const cstThisSub = "Array.IndexOf"
|
|
Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
|
|
lIndex = -1
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
|
|
iToFindType = SF_Utils._VarTypeExt(ToFind)
|
|
If SortOrder <> "" Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array", 1, iToFindType) Then GoTo Finally
|
|
Else
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array", 1) Then GoTo Finally
|
|
End If
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
vFindItem = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, UCase(SortOrder))
|
|
If vFindItem(0) = True Then lIndex = vFindItem(1) Else lIndex = LBound(Array_1D) - 1
|
|
|
|
Finally:
|
|
IndexOf = lIndex
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.IndexOf
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Insert(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal Before As Variant _
|
|
, ParamArray pvArgs() As Variant _
|
|
) As Variant
|
|
''' Insert before the index Before of the input array the items listed as arguments
|
|
''' Arguments are inserted blindly
|
|
''' each of them might be a scalar of any type or a subarray
|
|
''' Args
|
|
''' Array_1D: the pre-existing array, may be empty
|
|
''' Before: the index before which to insert; must be in the interval [LBound, UBound + 1]
|
|
''' pvArgs: a list of items to Insert inside Array_1D
|
|
''' Returns:
|
|
''' the new rxtended array. Its LBound is identical to that of Array_1D
|
|
''' Exceptions:
|
|
''' ARRAYINSERTERROR
|
|
''' Examples:
|
|
''' SF_Array.Insert(Array(1, 2, 3), 2, 4, 5) returns (1, 2, 4, 5, 3)
|
|
|
|
Dim vInsert As Variant ' Return value
|
|
Dim lNbArgs As Long ' Number of elements to Insert
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Insert"
|
|
Const cstSubArgs = "Array_1D, Before, arg0[, arg1] ..."
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vInsert = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
If Not SF_Utils._Validate(Before, "Before", V_NUMERIC) Then GoTo Finally
|
|
If Before < LBound(Array_1D) Or Before > UBound(Array_1D) + 1 Then GoTo CatchArgument
|
|
End If
|
|
|
|
Try:
|
|
lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based
|
|
lMin = LBound(Array_1D) ' = LBound(vInsert)
|
|
lMax = UBound(Array_1D) ' <> UBound(vInsert)
|
|
If lNbArgs > 0 Then
|
|
ReDim vInsert(lMin To lMax + lNbArgs)
|
|
For i = lMin To UBound(vInsert)
|
|
If i < Before Then
|
|
vInsert(i) = Array_1D(i)
|
|
ElseIf i < Before + lNbArgs Then
|
|
vInsert(i) = pvArgs(i - Before)
|
|
Else
|
|
vInsert(i) = Array_1D(i - lNbArgs)
|
|
End If
|
|
Next i
|
|
Else
|
|
vInsert() = Array_1D()
|
|
End If
|
|
|
|
Finally:
|
|
Insert = vInsert()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchArgument:
|
|
'TODO SF_Exception.RaiseFatal(ARRAYINSERTERROR, cstThisSub)
|
|
MsgBox "INVALID ARGUMENT VALUE !!"
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Insert
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function InsertSorted(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal Item As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Insert in a sorted array a new item on its place
|
|
''' the array must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' Args:
|
|
''' Array_1D: the array to sort
|
|
''' Item: the scalar value to insert, same type as the existing array items
|
|
''' SortOrder: "ASC" (default) or "DESC"
|
|
''' CaseSensitive: Default = False
|
|
''' Returns: the extended sorted array with same LBound as input array
|
|
''' Examples:
|
|
''' InsertSorted(Array("A", "C", "a", "b"), "B", CaseSensitive := True) returns ("A", "B", "C", "a", "b")
|
|
|
|
Dim vSorted() As Variant ' Return value
|
|
Dim iType As Integer ' VarType of elements in input array
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim lIndex As Long ' Place where to insert new item
|
|
Const cstThisSub = "Array.InsertSorted"
|
|
Const cstSubArgs = "Array_1D, Item, [SortOrder=""ASC""|""DESC""], [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vSorted = Array()
|
|
|
|
Check:
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC"
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0) Then GoTo Finally
|
|
If LBound(Array_1D) <= UBound(Array_1D) Then
|
|
iType = SF_Utils._VarTypeExt(Array_1D(LBound(Array_1D)))
|
|
If Not SF_Utils._Validate(Item, "Item", iType) Then GoTo Finally
|
|
Else
|
|
If Not SF_Utils._Validate(Item, "Item", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
|
|
End If
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lMax = UBound(Array_1D)
|
|
lIndex = SF_Array._FindItem(Array_1D, Item, CaseSensitive, UCase(SortOrder))(1)
|
|
vSorted = SF_Array.Insert(Array_1D, lIndex, Item)
|
|
|
|
Finally:
|
|
InsertSorted = vSorted()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.InsertSorted
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Intersection(Optional ByRef Array1_1D As Variant _
|
|
, Optional ByRef Array2_1D As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Build a set being the intersection of the two input arrays, i.e. items are contained in both arrays
|
|
''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' The comparison between strings is case sensitive or not
|
|
''' Args:
|
|
''' Array1_1D: a 1st input array
|
|
''' Array2_1D: a 2nd input array
|
|
''' CaseSensitive: default = False
|
|
''' Returns: a zero-based array containing unique items stored in both input arrays
|
|
''' The output array is sorted in ascending order
|
|
''' Examples:
|
|
''' Intersection(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("C", "b")
|
|
|
|
Dim vIntersection() As Variant ' Return value
|
|
Dim vSorted() As Variant ' The shortest input array after sort
|
|
Dim iType As Integer ' VarType of elements in input arrays
|
|
Dim lMin1 As Long ' LBound of 1st input array
|
|
Dim lMax1 As Long ' UBound of 1st input array
|
|
Dim lMin2 As Long ' LBound of 2nd input array
|
|
Dim lMax2 As Long ' UBound of 2nd input array
|
|
Dim lMin As Long ' LBound of unsorted array
|
|
Dim lMax As Long ' UBound of unsorted array
|
|
Dim iShortest As Integer ' 1 or 2 depending on shortest input array
|
|
Dim lSize As Long ' Number of Intersection items
|
|
Dim vItem As Variant ' One single item in the array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Intersection"
|
|
Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vIntersection = Array()
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally
|
|
iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
|
|
If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
|
|
lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
|
|
|
|
' If one of both arrays is empty, do nothing
|
|
If lMax1 >= lMin1 And lMax2 >= lMin2 Then
|
|
|
|
' First sort the shortest array
|
|
If lMax1 - lMin1 <= lMax2 - lMin2 Then
|
|
iShortest = 1
|
|
vSorted = SF_Array.Sort(Array1_1D, "ASC", CaseSensitive)
|
|
lMin = lMin2 : lMax = lMax2 ' Bounds of unsorted array
|
|
Else
|
|
iShortest = 2
|
|
vSorted = SF_Array.Sort(Array2_1D, "ASC", CaseSensitive)
|
|
lMin = lMin1 : lMax = lMax1 ' Bounds of unsorted array
|
|
End If
|
|
|
|
' Resize the output array to the size of the shortest array
|
|
ReDim vIntersection(0 To (lMax - lMin))
|
|
lSize = -1
|
|
|
|
' Fill vIntersection one by one only with items present in both sets
|
|
For i = lMin To lMax
|
|
If iShortest = 1 Then vItem = Array2_1D(i) Else vItem = Array1_1D(i) ' Pick in unsorted array
|
|
If SF_Array.Contains(vSorted, vItem, CaseSensitive, "ASC") Then
|
|
lSize = lSize + 1
|
|
vIntersection(lSize) = vItem
|
|
End If
|
|
Next i
|
|
|
|
' Remove unfilled entries and duplicates
|
|
If lSize >= 0 Then
|
|
ReDim Preserve vIntersection(0 To lSize)
|
|
vIntersection() = SF_Array.Unique(vIntersection, CaseSensitive)
|
|
Else
|
|
vIntersection = Array()
|
|
End If
|
|
End If
|
|
|
|
Finally:
|
|
Intersection = vIntersection()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Intersection
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Join2D(Optional ByRef Array_2D As Variant _
|
|
, Optional ByVal ColumnDelimiter As Variant _
|
|
, Optional ByVal RowDelimiter As Variant _
|
|
, Optional ByVal Quote As Variant _
|
|
) As String
|
|
''' Join a two-dimensional array with two delimiters, one for columns, one for rows
|
|
''' Args:
|
|
''' Array_2D: each item must be either a String, a number, a Date or a Boolean
|
|
''' ColumnDelimiter: delimits each column (default = Tab/Chr(9))
|
|
''' RowDelimiter: delimits each row (default = LineFeed/Chr(10))
|
|
''' Quote: if True, protect strings with double quotes (default = False)
|
|
''' Return:
|
|
''' A string after conversion of numbers and dates
|
|
''' Invalid items are replaced by a zero-length string
|
|
''' Examples:
|
|
''' | 1, 2, "A", [2020-02-29], 5 |
|
|
''' SF_Array.Join_2D( | 6, 7, "this is a string", 9, 10 | , ",", "/")
|
|
''' ' "1,2,A,2020-02-29 00:00:00,5/6,7,this is a string,9,10"
|
|
|
|
Dim sJoin As String ' The return value
|
|
Dim sItem As String ' The string representation of a single item
|
|
Dim vItem As Variant ' Single item
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.Join2D"
|
|
Const cstSubArgs = "Array_2D, [ColumnDelimiter=Chr(9)], [RowDelimiter=Chr(10)], [Quote=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
sJoin = ""
|
|
|
|
Check:
|
|
If IsMissing(ColumnDelimiter) Or IsEmpty(ColumnDelimiter) Then ColumnDelimiter = Chr(9)
|
|
If IsMissing(RowDelimiter) Or IsEmpty(RowDelimiter) Then RowDelimiter = Chr(10)
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ColumnDelimiter, "ColumnDelimiter", V_STRING) Then GoTo Finally
|
|
If Not SF_Utils._Validate(RowDelimiter, "RowDelimiter", V_STRING) Then GoTo Finally
|
|
If Not SF_Utils._Validate(Quote, "Quote", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
If lMin1 <= lMax1 Then
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
vItem = Array_2D(i, j)
|
|
Select Case SF_Utils._VarTypeExt(vItem)
|
|
Case V_STRING : If Quote Then sItem = SF_String.Quote(vItem) Else sItem = vItem
|
|
Case V_NUMERIC, V_DATE : sItem = SF_Utils._Repr(vItem)
|
|
Case V_BOOLEAN : sItem = Iif(vItem, "True", "False") 'TODO: L10N
|
|
Case Else : sItem = ""
|
|
End Select
|
|
sJoin = sJoin & sItem & Iif(j < lMax2, ColumnDelimiter, "")
|
|
Next j
|
|
sJoin = sJoin & Iif(i < lMax1, RowDelimiter, "")
|
|
Next i
|
|
End If
|
|
|
|
Finally:
|
|
Join2D = sJoin
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Join2D
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Methods() As Variant
|
|
''' Return the list of public methods of the Array service as an array
|
|
|
|
Methods = Array( _
|
|
"Append" _
|
|
, "AppendColumn" _
|
|
, "AppendRow" _
|
|
, "Contains" _
|
|
, "ConvertToDictionary" _
|
|
, "CountDims" _
|
|
, "Difference" _
|
|
, "ExportToTextFile" _
|
|
, "ExtractColumn" _
|
|
, "ExtractRow" _
|
|
, "Flatten" _
|
|
, "ImportFromCSVFile" _
|
|
, "IndexOf" _
|
|
, "Insert" _
|
|
, "InsertSorted" _
|
|
, "Intersection" _
|
|
, "Join2D" _
|
|
, "Prepend" _
|
|
, "PrependColumn" _
|
|
, "PrependRow" _
|
|
, "RangeInit" _
|
|
, "Reverse" _
|
|
, "Shuffle" _
|
|
, "Sort" _
|
|
, "SortColumns" _
|
|
, "SortRows" _
|
|
, "Transpose" _
|
|
, "TrimArray" _
|
|
, "Union" _
|
|
, "Unique" _
|
|
)
|
|
|
|
End Function ' ScriptForge.SF_Array.Methods
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Prepend(Optional ByRef Array_1D As Variant _
|
|
, ParamArray pvArgs() As Variant _
|
|
) As Variant
|
|
''' Prepend at the beginning of the input array the items listed as arguments
|
|
''' Arguments are Prepended blindly
|
|
''' each of them might be a scalar of any type or a subarray
|
|
''' Args
|
|
''' Array_1D: the pre-existing array, may be empty
|
|
''' pvArgs: a list of items to Prepend to Array_1D
|
|
''' Return: the new rxtended array. Its LBound is identical to that of Array_1D
|
|
''' Examples:
|
|
''' SF_Array.Prepend(Array(1, 2, 3), 4, 5) returns (4, 5, 1, 2, 3)
|
|
|
|
Dim vPrepend As Variant ' Return value
|
|
Dim lNbArgs As Long ' Number of elements to Prepend
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Prepend"
|
|
Const cstSubArgs = "Array_1D, arg0[, arg1] ..."
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vPrepend = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based
|
|
lMin = LBound(Array_1D) ' = LBound(vPrepend)
|
|
lMax = UBound(Array_1D) ' <> UBound(vPrepend)
|
|
If lMax < LBound(Array_1D) And lNbArgs > 0 Then ' Initial array is empty
|
|
ReDim vPrepend(0 To lNbArgs - 1)
|
|
Else
|
|
ReDim vPrepend(lMin To lMax + lNbArgs)
|
|
End If
|
|
For i = lMin To UBound(vPrepend)
|
|
If i < lMin + lNbArgs Then vPrepend(i) = pvArgs(i - lMin) Else vPrepend(i) = Array_1D(i - lNbArgs)
|
|
Next i
|
|
|
|
Finally:
|
|
Prepend = vPrepend
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Prepend
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function PrependColumn(Optional ByRef Array_2D As Variant _
|
|
, Optional ByRef Column As Variant _
|
|
) As Variant
|
|
''' PrependColumn prepends to the left side of a 2D array a new Column
|
|
''' Args
|
|
''' Array_2D: the pre-existing array, may be empty
|
|
''' If the array has 1 dimension, it is considered as the last Column of the resulting 2D array
|
|
''' Column: a 1D array with as many items as there are rows in Array_2D
|
|
''' Returns:
|
|
''' the new rxtended array. Its LBounds are identical to that of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINSERTERROR
|
|
''' Examples:
|
|
''' SF_Array.PrependColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 1), (5, 2), (6, 3))
|
|
''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
|
|
|
|
Dim vPrependColumn As Variant ' Return value
|
|
Dim iDims As Integer ' Dimensions of Array_2D
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim lMin As Long ' LBound of Column array
|
|
Dim lMax As Long ' UBound of Column array
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.PrependColumn"
|
|
Const cstSubArgs = "Array_2D, Column"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vPrependColumn = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
|
|
If Not SF_Utils._ValidateArray(Column, "Column", 1) Then GoTo Finally
|
|
End If
|
|
iDims = SF_Array.CountDims(Array_2D)
|
|
If iDims > 2 Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Column)
|
|
lMax = UBound(Column)
|
|
|
|
' Compute future dimensions of output array
|
|
Select Case iDims
|
|
Case 0 : lMin1 = lMin : lMax1 = lMax
|
|
lMin2 = 0 : lMax2 = -1
|
|
Case 1 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = 0 : lMax2 = 0
|
|
Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
End Select
|
|
If iDims > 0 And lMax - lMin <> lMax1 - lMin1 Then GoTo CatchColumn
|
|
ReDim vPrependColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
|
|
|
|
' Copy input array to output array
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 + 1 To lMax2 + 1
|
|
If iDims = 2 Then vPrependColumn(i, j) = Array_2D(i, j - 1) Else vPrependColumn(i, j) = Array_2D(i)
|
|
Next j
|
|
Next i
|
|
' Copy new Column
|
|
For i = lMin1 To lMax1
|
|
vPrependColumn(i, lMin2) = Column(i)
|
|
Next i
|
|
|
|
Finally:
|
|
PrependColumn = vPrependColumn()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchColumn:
|
|
SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.PrependColumn
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function PrependRow(Optional ByRef Array_2D As Variant _
|
|
, Optional ByRef Row As Variant _
|
|
) As Variant
|
|
''' PrependRow prepends on top of a 2D array a new row
|
|
''' Args
|
|
''' Array_2D: the pre-existing array, may be empty
|
|
''' If the array has 1 dimension, it is considered as the last row of the resulting 2D array
|
|
''' Row: a 1D array with as many items as there are columns in Array_2D
|
|
''' Returns:
|
|
''' the new rxtended array. Its LBounds are identical to that of Array_2D
|
|
''' Exceptions:
|
|
''' ARRAYINSERTERROR
|
|
''' Examples:
|
|
''' SF_Array.PrependRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 5, 6), (1, 2, 3))
|
|
''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
|
|
|
|
Dim vPrependRow As Variant ' Return value
|
|
Dim iDims As Integer ' Dimensions of Array_2D
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim lMin As Long ' LBound of row array
|
|
Dim lMax As Long ' UBound of row array
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Const cstThisSub = "Array.PrependRow"
|
|
Const cstSubArgs = "Array_2D, Row"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vPrependRow = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
|
|
If Not SF_Utils._ValidateArray(Row, "Row", 1) Then GoTo Finally
|
|
End If
|
|
iDims = SF_Array.CountDims(Array_2D)
|
|
If iDims > 2 Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Row)
|
|
lMax = UBound(Row)
|
|
|
|
' Compute future dimensions of output array
|
|
Select Case iDims
|
|
Case 0 : lMin1 = 0 : lMax1 = -1
|
|
lMin2 = lMin : lMax2 = lMax
|
|
Case 1 : lMin1 = 0 : lMax1 = 0
|
|
lMin2 = LBound(Array_2D, 1) : lMax2 = UBound(Array_2D, 1)
|
|
Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
End Select
|
|
If iDims > 0 And lMax - lMin <> lMax2 - lMin2 Then GoTo CatchRow
|
|
ReDim vPrependRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
|
|
|
|
' Copy input array to output array
|
|
For i = lMin1 + 1 To lMax1 + 1
|
|
For j = lMin2 To lMax2
|
|
If iDims = 2 Then vPrependRow(i, j) = Array_2D(i - 1, j) Else vPrependRow(i, j) = Array_2D(j)
|
|
Next j
|
|
Next i
|
|
' Copy new row
|
|
For j = lMin2 To lMax2
|
|
vPrependRow(lMin1, j) = Row(j)
|
|
Next j
|
|
|
|
Finally:
|
|
PrependRow = vPrependRow()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchRow:
|
|
SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.PrependRow
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Properties() As Variant
|
|
''' Return the list or properties as an array
|
|
|
|
Properties = Array( _
|
|
)
|
|
|
|
End Function ' ScriptForge.SF_Array.Properties
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function RangeInit(Optional ByVal From As Variant _
|
|
, Optional ByVal UpTo As Variant _
|
|
, Optional ByVal ByStep As Variant _
|
|
) As Variant
|
|
''' Initialize a new zero-based array with numeric values
|
|
''' Args: all numeric
|
|
''' From: value of first item
|
|
''' UpTo: last item should not exceed UpTo
|
|
''' ByStep: difference between 2 successive items
|
|
''' Return: the new array
|
|
''' Exceptions:
|
|
''' ARRAYSEQUENCEERROR Wrong arguments, f.i. UpTo < From with ByStep > 0
|
|
''' Examples:
|
|
''' SF_Array.RangeInit(10, 1, -1) returns (10, 9, 8, 7, 6, 5, 4, 3, 2, 1)
|
|
|
|
Dim lIndex As Long ' Index of array
|
|
Dim lSize As Long ' UBound of resulting array
|
|
Dim vCurrentItem As Variant ' Last stored item
|
|
Dim vArray() ' The return value
|
|
Const cstThisSub = "Array.RangeInit"
|
|
Const cstSubArgs = "From, UpTo, [ByStep = 1]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vArray = Array()
|
|
|
|
Check:
|
|
If IsMissing(ByStep) Or IsEmpty(ByStep) Then ByStep = 1
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(From, "From", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(UpTo, "UpTo", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ByStep, "ByStep", V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
If (From < UpTo And ByStep <= 0) Or (From > UpTo And ByStep >= 0) Then GoTo CatchSequence
|
|
|
|
Try:
|
|
lSize = CLng(Abs((UpTo - From) / ByStep))
|
|
ReDim vArray(0 To lSize)
|
|
For lIndex = 0 To lSize
|
|
vArray(lIndex) = From + lIndex * ByStep
|
|
Next lIndex
|
|
|
|
Finally:
|
|
RangeInit = vArray
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchSequence:
|
|
SF_Exception.RaiseFatal(ARRAYSEQUENCEERROR, From, UpTo, ByStep)
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.RangeInit
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Reverse(Optional ByRef Array_1D As Variant) As Variant
|
|
''' Return the reversed 1D input array
|
|
''' Args:
|
|
''' Array_1D: the array to reverse
|
|
''' Returns: the reversed array
|
|
''' Examples:
|
|
''' SF_Array.Reverse(Array(1, 2, 3, 4)) returns (4, 3, 2, 1)
|
|
|
|
Dim vReverse() As Variant ' Return value
|
|
Dim lHalf As Long ' Middle of array
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim i As Long, j As Long
|
|
Const cstThisSub = "Array.Reverse"
|
|
Const cstSubArgs = "Array_1D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vReverse = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lMax = UBound(Array_1D)
|
|
ReDim vReverse(lMin To lMax)
|
|
lHalf = Int((lMax + lMin) / 2)
|
|
j = lMax
|
|
For i = lMin To lHalf
|
|
vReverse(i) = Array_1D(j)
|
|
vReverse(j) = Array_1D(i)
|
|
j = j - 1
|
|
Next i
|
|
' Odd number of items
|
|
If IsEmpty(vReverse(lHalf + 1)) Then vReverse(lHalf + 1) = Array_1D(lHalf + 1)
|
|
|
|
Finally:
|
|
Reverse = vReverse()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Reverse
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function SetProperty(Optional ByVal PropertyName As Variant _
|
|
, Optional ByRef Value As Variant _
|
|
) As Boolean
|
|
''' Set a new value to the given property
|
|
''' Args:
|
|
''' PropertyName: the name of the property as a string
|
|
''' Value: its new value
|
|
''' Exceptions
|
|
''' ARGUMENTERROR The property does not exist
|
|
|
|
Const cstThisSub = "Array.SetProperty"
|
|
Const cstSubArgs = "PropertyName, Value"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
SetProperty = False
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
|
|
End If
|
|
|
|
Try:
|
|
Select Case UCase(PropertyName)
|
|
Case Else
|
|
End Select
|
|
|
|
Finally:
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.SetProperty
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Shuffle(Optional ByRef Array_1D As Variant) As Variant
|
|
''' Returns a random permutation of a 1D array
|
|
''' https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle
|
|
''' Args:
|
|
''' Array_1D: the array to shuffle
|
|
''' Returns: the shuffled array
|
|
|
|
Dim vShuffle() As Variant ' Return value
|
|
Dim vSwapValue As Variant ' Intermediate value during swap
|
|
Dim lMin As Long ' LBound of Array_1D
|
|
Dim lCurrentIndex As Long ' Decremented from UBount to LBound
|
|
Dim lRandomIndex As Long ' Random between LBound and lCurrentIndex
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Shuffle"
|
|
Const cstSubArgs = "Array_1D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vShuffle = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lCurrentIndex = UBound(array_1D)
|
|
' Initialize the output array
|
|
ReDim vShuffle(lMin To lCurrentIndex)
|
|
For i = lMin To lCurrentIndex
|
|
vShuffle(i) = Array_1D(i)
|
|
Next i
|
|
' Now ... shuffle !
|
|
Do While lCurrentIndex > lMin
|
|
lRandomIndex = Int(Rnd * (lCurrentIndex - lMin + 1)) + lMin
|
|
vSwapValue = vShuffle(lCurrentIndex)
|
|
vShuffle(lCurrentIndex) = vShuffle(lRandomIndex)
|
|
vShuffle(lRandomIndex) = vSwapValue
|
|
lCurrentIndex = lCurrentIndex - 1
|
|
Loop
|
|
|
|
Finally:
|
|
Shuffle = vShuffle()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Shuffle
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Slice(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal From As Variant _
|
|
, Optional ByVal UpTo As Variant _
|
|
) As Variant
|
|
''' Returns a subset of a 1D array
|
|
''' Args:
|
|
''' Array_1D: the array to slice
|
|
''' From: the lower index of the subarray to extract (included)
|
|
''' UpTo: the upper index of the subarray to extract (included). Default = the last item of Array_1D
|
|
''' Returns:
|
|
''' The selected subarray with the same LBound as the input array.
|
|
''' If UpTo < From then the returned array is empty
|
|
''' Exceptions:
|
|
''' ARRAYINDEX2ERROR Wrong values for From and/or UpTo
|
|
''' Example:
|
|
''' SF_Array.Slice(Array(1, 2, 3, 4, 5), 1, 3) returns (2, 3, 4)
|
|
|
|
Dim vSlice() As Variant ' Return value
|
|
Dim lMin As Long ' LBound of Array_1D
|
|
Dim lIndex As Long ' Current index in output array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Slice"
|
|
Const cstSubArgs = "Array_1D, From, [UpTo = UBound(Array_1D)]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vSlice = Array()
|
|
|
|
Check:
|
|
If IsMissing(UpTo) Or IsEmpty(UpTo) Then UpTo = -1
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
If Not SF_Utils._Validate(From, "From", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(UpTo, "UpTo", V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
If UpTo = -1 Then UpTo = UBound(Array_1D)
|
|
If From < LBound(Array_1D) Or From > UBound(Array_1D) _
|
|
Or From > UpTo Or UpTo > UBound(Array_1D) Then GoTo CatchIndex
|
|
|
|
Try:
|
|
If UpTo >= From Then
|
|
lMin = LBound(Array_1D)
|
|
' Initialize the output array
|
|
ReDim vSlice(lMin To lMin + UpTo - From)
|
|
lIndex = lMin - 1
|
|
For i = From To UpTo
|
|
lIndex = lIndex + 1
|
|
vSlice(lIndex) = Array_1D(i)
|
|
Next i
|
|
End If
|
|
|
|
Finally:
|
|
Slice = vSlice()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchIndex:
|
|
SF_Exception.RaiseFatal(ARRAYINDEX2ERROR, SF_Array._Repr(Array_1D), From, UpTo)
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Slice
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Sort(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Sort a 1D array in ascending or descending order. String comparisons can be case-sensitive or not
|
|
''' Args:
|
|
''' Array_1D: the array to sort
|
|
''' must be filled homogeneously by either strings, dates or numbers
|
|
''' Null and Empty values are allowed
|
|
''' SortOrder: "ASC" (default) or "DESC"
|
|
''' CaseSensitive: Default = False
|
|
''' Returns: the sorted array
|
|
''' Examples:
|
|
''' Sort(Array("a", "A", "b", "B", "C"), CaseSensitive := True) returns ("A", "B", "C", "a", "b")
|
|
|
|
Dim vSort() As Variant ' Return value
|
|
Dim vIndexes() As Variant ' Indexes of sorted items
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Sort"
|
|
Const cstSubArgs = "Array_1D, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vSort = Array()
|
|
|
|
Check:
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC"
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0) Then GoTo Finally
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lMax = UBound(Array_1D)
|
|
If lMax < lMin Then GoTo Finally ' Do nothing if the input array is empty
|
|
vIndexes() = SF_Array._HeapSort(Array_1D, ( UCase(SortOrder) = "ASC" ), CaseSensitive)
|
|
|
|
' Load output array
|
|
ReDim vSort(lMin To lMax)
|
|
For i = lMin To lMax
|
|
vSort(i) = Array_1D(vIndexes(i))
|
|
Next i
|
|
|
|
Finally:
|
|
Sort = vSort()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Sort
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function SortColumns(Optional ByRef Array_2D As Variant _
|
|
, Optional ByVal RowIndex As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Returns a permutation of the columns of a 2D array, sorted on the values of a given row
|
|
''' Args:
|
|
''' Array_2D: the input array
|
|
''' RowIndex: the index of the row to sort the columns on
|
|
''' the row must be filled homogeneously by either strings, dates or numbers
|
|
''' Null and Empty values are allowed
|
|
''' SortOrder: "ASC" (default) or "DESC"
|
|
''' CaseSensitive: Default = False
|
|
''' Returns:
|
|
''' the array with permuted columns, LBounds and UBounds are unchanged
|
|
''' Exceptions:
|
|
''' ARRAYINDEXERROR
|
|
''' Examples:
|
|
''' | 5, 7, 3 | | 7, 5, 3 |
|
|
''' SF_Array.SortColumns( | 1, 9, 5 |, 2, "ASC") returns | 9, 1, 5 |
|
|
''' | 6, 1, 8 | | 1, 6, 8 |
|
|
|
|
Dim vSort() As Variant ' Return value
|
|
Dim vRow() As Variant ' The row on which to sort the array
|
|
Dim vIndexes() As Variant ' Indexes of sorted row
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim i As Long, j As Long
|
|
Const cstThisSub = "Array.SortColumn"
|
|
Const cstSubArgs = "Array_2D, RowIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vSort = Array()
|
|
|
|
Check:
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC"
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
If Not SF_Utils._Validate(RowIndex, "RowIndex", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
If RowIndex < lMin1 Or RowIndex > lMax1 Then GoTo CatchIndex
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
|
|
' Extract and sort the RowIndex-th row
|
|
vRow = SF_Array.ExtractRow(Array_2D, RowIndex)
|
|
If Not SF_Utils._ValidateArray(vRow, "Row #" & CStr(RowIndex), 1, 0) Then GoTo Finally
|
|
vIndexes() = SF_Array._HeapSort(vRow, ( UCase(SortOrder) = "ASC" ), CaseSensitive)
|
|
|
|
' Load output array
|
|
ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
vSort(i, j) = Array_2D(i, vIndexes(j))
|
|
Next j
|
|
Next i
|
|
|
|
Finally:
|
|
SortColumns = vSort()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchIndex:
|
|
'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
|
|
MsgBox "INVALID INDEX VALUE !!"
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.SortColumns
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function SortRows(Optional ByRef Array_2D As Variant _
|
|
, Optional ByVal ColumnIndex As Variant _
|
|
, Optional ByVal SortOrder As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Returns a permutation of the rows of a 2D array, sorted on the values of a given column
|
|
''' Args:
|
|
''' Array_2D: the input array
|
|
''' ColumnIndex: the index of the column to sort the rows on
|
|
''' the column must be filled homogeneously by either strings, dates or numbers
|
|
''' Null and Empty values are allowed
|
|
''' SortOrder: "ASC" (default) or "DESC"
|
|
''' CaseSensitive: Default = False
|
|
''' Returns:
|
|
''' the array with permuted Rows, LBounds and UBounds are unchanged
|
|
''' Exceptions:
|
|
''' ARRAYINDEXERROR
|
|
''' Examples:
|
|
''' | 5, 7, 3 | | 1, 9, 5 |
|
|
''' SF_Array.SortRows( | 1, 9, 5 |, 0, "ASC") returns | 5, 7, 3 |
|
|
''' | 6, 1, 8 | | 6, 1, 8 |
|
|
|
|
Dim vSort() As Variant ' Return value
|
|
Dim vCol() As Variant ' The column on which to sort the array
|
|
Dim vIndexes() As Variant ' Indexes of sorted row
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim i As Long, j As Long
|
|
Const cstThisSub = "Array.SortRow"
|
|
Const cstSubArgs = "Array_2D, ColumnIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vSort = Array()
|
|
|
|
Check:
|
|
If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC"
|
|
If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
If Not SF_Utils._Validate(ColumnIndex, "ColumnIndex", V_NUMERIC) Then GoTo Finally
|
|
If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
If ColumnIndex < lMin2 Or ColumnIndex > lMax2 Then GoTo CatchIndex
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
|
|
' Extract and sort the ColumnIndex-th column
|
|
vCol = SF_Array.ExtractColumn(Array_2D, ColumnIndex)
|
|
If Not SF_Utils._ValidateArray(vCol, "Column #" & CStr(ColumnIndex), 1, 0) Then GoTo Finally
|
|
vIndexes() = SF_Array._HeapSort(vCol, ( UCase(SortOrder) = "ASC" ), CaseSensitive)
|
|
|
|
' Load output array
|
|
ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
vSort(i, j) = Array_2D(vIndexes(i), j)
|
|
Next j
|
|
Next i
|
|
|
|
Finally:
|
|
SortRows = vSort()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
CatchIndex:
|
|
'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
|
|
MsgBox "INVALID INDEX VALUE !!"
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.SortRows
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Transpose(Optional ByRef Array_2D As Variant) As Variant
|
|
''' Swaps rows and columns in a 2D array
|
|
''' Args:
|
|
''' Array_2D: the array to transpose
|
|
''' Returns:
|
|
''' The transposed array
|
|
''' Examples:
|
|
''' | 1, 2 | | 1, 3, 5 |
|
|
''' SF_Array.Transpose( | 3, 4 | ) returns | 2, 4, 6 |
|
|
''' | 5, 6 |
|
|
|
|
Dim vTranspose As Variant ' Return value
|
|
Dim lIndex As Long ' vTranspose index
|
|
Dim lMin1 As Long ' LBound1 of input array
|
|
Dim lMax1 As Long ' UBound1 of input array
|
|
Dim lMin2 As Long ' LBound2 of input array
|
|
Dim lMax2 As Long ' UBound2 of input array
|
|
Dim i As Long, j As Long
|
|
Const cstThisSub = "Array.Transpose"
|
|
Const cstSubArgs = "Array_2D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vTranspose = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
' Resize the output array
|
|
lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1)
|
|
lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2)
|
|
If lMin1 <= lMax1 Then
|
|
ReDim vTranspose(lMin2 To lMax2, lMin1 To lMax1)
|
|
End If
|
|
|
|
' Transpose items
|
|
For i = lMin1 To lMax1
|
|
For j = lMin2 To lMax2
|
|
vTranspose(j, i) = Array_2D(i, j)
|
|
Next j
|
|
Next i
|
|
|
|
Finally:
|
|
Transpose = vTranspose
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Transpose
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function TrimArray(Optional ByRef Array_1D As Variant) As Variant
|
|
''' Remove from a 1D array all Null, Empty and zero-length entries
|
|
''' Strings are trimmed as well
|
|
''' Args:
|
|
''' Array_1D: the array to scan
|
|
''' Return: The trimmed array
|
|
''' Examples:
|
|
''' SF_Array.TrimArray(Array("A","B",Null," D ")) returns ("A","B","D")
|
|
|
|
Dim vTrimArray As Variant ' Return value
|
|
Dim lIndex As Long ' vTrimArray index
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim vItem As Variant ' Single array item
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.TrimArray"
|
|
Const cstSubArgs = "Array_1D"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vTrimArray = Array()
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lMax = UBound(Array_1D)
|
|
If lMin <= lMax Then
|
|
ReDim vTrimArray(lMin To lMax)
|
|
End If
|
|
lIndex = lMin - 1
|
|
|
|
' Load only valid items from Array_1D to vTrimArray
|
|
For i = lMin To lMax
|
|
vItem = Array_1D(i)
|
|
Select Case VarType(vItem)
|
|
Case V_EMPTY
|
|
Case V_NULL : vItem = Empty
|
|
Case V_STRING
|
|
vItem = Trim(vItem)
|
|
If Len(vItem) = 0 Then vItem = Empty
|
|
Case Else
|
|
End Select
|
|
If Not IsEmpty(vItem) Then
|
|
lIndex = lIndex + 1
|
|
vTrimArray(lIndex) = vItem
|
|
End If
|
|
Next i
|
|
|
|
'Keep valid entries
|
|
If lMin <= lIndex Then
|
|
ReDim Preserve vTrimArray(lMin To lIndex)
|
|
Else
|
|
vTrimArray = Array()
|
|
End If
|
|
|
|
Finally:
|
|
TrimArray = vTrimArray
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.TrimArray
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Union(Optional ByRef Array1_1D As Variant _
|
|
, Optional ByRef Array2_1D As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Build a set being the Union of the two input arrays, i.e. items are contained in any of both arrays
|
|
''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' The comparison between strings is case sensitive or not
|
|
''' Args:
|
|
''' Array1_1D: a 1st input array
|
|
''' Array2_1D: a 2nd input array
|
|
''' CaseSensitive: default = False
|
|
''' Returns: a zero-based array containing unique items stored in any of both input arrays
|
|
''' The output array is sorted in ascending order
|
|
''' Examples:
|
|
''' SF_Array.Union(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B", "C", "Z", "b")
|
|
|
|
Dim vUnion() As Variant ' Return value
|
|
Dim iType As Integer ' VarType of elements in input arrays
|
|
Dim lMin1 As Long ' LBound of 1st input array
|
|
Dim lMax1 As Long ' UBound of 1st input array
|
|
Dim lMin2 As Long ' LBound of 2nd input array
|
|
Dim lMax2 As Long ' UBound of 2nd input array
|
|
Dim lSize As Long ' Number of Union items
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Union"
|
|
Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vUnion = Array()
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally
|
|
iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
|
|
If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
|
|
lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
|
|
|
|
' If both arrays are empty, do nothing
|
|
If lMax1 < lMin1 And lMax2 < lMin2 Then
|
|
ElseIf lMax1 < lMin1 Then ' only 1st array is empty
|
|
vUnion = SF_Array.Unique(Array2_1D, CaseSensitive)
|
|
ElseIf lMax2 < lMin2 Then ' only 2nd array is empty
|
|
vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
|
|
Else
|
|
|
|
' Build union of both arrays
|
|
ReDim vUnion(0 To (lMax1 - lMin1) + (lMax2 - lMin2) + 1)
|
|
lSize = -1
|
|
|
|
' Fill vUnion one by one only with items present in any set
|
|
For i = lMin1 To lMax1
|
|
lSize = lSize + 1
|
|
vUnion(lSize) = Array1_1D(i)
|
|
Next i
|
|
For i = lMin2 To lMax2
|
|
lSize = lSize + 1
|
|
vUnion(lSize) = Array2_1D(i)
|
|
Next i
|
|
|
|
' Remove duplicates
|
|
vUnion() = SF_Array.Unique(vUnion, CaseSensitive)
|
|
End If
|
|
|
|
Finally:
|
|
Union = vUnion()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Union
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Unique(Optional ByRef Array_1D As Variant _
|
|
, Optional ByVal CaseSensitive As Variant _
|
|
) As Variant
|
|
''' Build a set of unique values derived from the input array
|
|
''' the input array must be filled homogeneously, i.e. all items must be of the same type
|
|
''' Empty and Null items are forbidden
|
|
''' The comparison between strings is case sensitive or not
|
|
''' Args:
|
|
''' Array_1D: the input array with potential duplicates
|
|
''' CaseSensitive: default = False
|
|
''' Returns: the array without duplicates with same LBound as input array
|
|
''' The output array is sorted in ascending order
|
|
''' Examples:
|
|
''' Unique(Array("A", "C", "A", "b", "B"), True) returns ("A", "B", "C", "b")
|
|
|
|
Dim vUnique() As Variant ' Return value
|
|
Dim vSorted() As Variant ' The input array after sort
|
|
Dim lMin As Long ' LBound of input array
|
|
Dim lMax As Long ' UBound of input array
|
|
Dim lUnique As Long ' Number of unique items
|
|
Dim vIndex As Variant ' Output of _FindItem() method
|
|
Dim vItem As Variant ' One single item in the array
|
|
Dim i As Long
|
|
Const cstThisSub = "Array.Unique"
|
|
Const cstSubArgs = "Array_1D, [CaseSensitive=False]"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vUnique = Array()
|
|
|
|
Check:
|
|
If IsMissing(CaseSensitive) Then CaseSensitive = False
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0, True) Then GoTo Finally
|
|
If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
lMin = LBound(Array_1D)
|
|
lMax = UBound(Array_1D)
|
|
If lMax >= lMin Then
|
|
' First sort the array
|
|
vSorted = SF_Array.Sort(Array_1D, "ASC", CaseSensitive)
|
|
ReDim vUnique(lMin To lMax)
|
|
lUnique = lMin
|
|
' Fill vUnique one by one ignoring duplicates
|
|
For i = lMin To lMax
|
|
vItem = vSorted(i)
|
|
If i = lMin Then
|
|
vUnique(i) = vItem
|
|
Else
|
|
If SF_Array._ValCompare(vItem, vSorted(i - 1), CaseSensitive) = 0 Then ' Ignore item
|
|
Else
|
|
lUnique = lUnique + 1
|
|
vUnique(lUnique) = vItem
|
|
End If
|
|
End If
|
|
Next i
|
|
' Remove unfilled entries
|
|
ReDim Preserve vUnique(lMin To lUnique)
|
|
End If
|
|
|
|
Finally:
|
|
Unique = vUnique()
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' ScriptForge.SF_Array.Unique
|
|
|
|
REM ============================================================= PRIVATE METHODS
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _ConvertToCellValue(ByVal pvItem As Variant _
|
|
, ByVal pbIsCell As Boolean _
|
|
) As Variant
|
|
''' Convert the argument to a valid Calc cell content, i.e. a string or a double.
|
|
''' When the argument is not immediately convertible, either
|
|
''' - the cell range is returned unchanged if the argument is a UNO com.sun.star.table.XCellRange object
|
|
''' - the date is converted to a double when the argument is a UNO com.sun.star.util.DateTime object
|
|
''' - the zero-length string is returned (pbIsCell = True)
|
|
''' - the argument is returned unchanged (pbIsCell = False)
|
|
|
|
Dim vCell As Variant ' Return value
|
|
Dim oObjectDescriptor As Object ' Object descriptor (see SF_Utils)
|
|
|
|
Try:
|
|
' Conversion takes place only when pbIsCell = True
|
|
If pbIsCell Then
|
|
Select Case SF_Utils._VarTypeExt(pvItem)
|
|
Case V_STRING : vCell = pvItem
|
|
Case V_DATE : vCell = CDbl(pvItem)
|
|
Case V_NUMERIC : vCell = CDbl(pvItem)
|
|
Case V_BOOLEAN : vCell = CDbl(Iif(pvItem, 1, 0))
|
|
Case V_OBJECT
|
|
Set oObjectDescriptor = SF_Utils._VarTypeObj(pvItem)
|
|
Select Case oObjectDescriptor.sObjectType
|
|
Case "ScCellRangeObj" : vCell = pvItem
|
|
Case "com.sun.star.util.DateTime" : vCell = CDbl(CDateFromUnoDateTime(pvItem)) ' Python date
|
|
Case Else : vCell = ""
|
|
End Select
|
|
Case Else : vCell = ""
|
|
End Select
|
|
Else ' Return the input item unchanged
|
|
vCell = pvItem
|
|
End If
|
|
|
|
Finally:
|
|
_ConvertToCellValue = vCell
|
|
Exit Function
|
|
End Function ' ScriptForge.SF_Array._ConvertToCellValue
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function _FindItem(ByRef pvArray_1D As Variant _
|
|
, ByVal pvToFind As Variant _
|
|
, ByVal pbCaseSensitive As Boolean _
|
|
, ByVal psSortOrder As String _
|
|
) As Variant
|
|
''' Check if a 1D array contains the ToFind number, string or date and return its index
|
|
''' The comparison between strings can be done case-sensitively or not
|
|
''' If the array is sorted then a binary search is done
|
|
''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
|
|
''' Args:
|
|
''' pvArray_1D: the array to scan
|
|
''' pvToFind: a number, a date or a string to find
|
|
''' pbCaseSensitive: Only for string comparisons, default = False
|
|
''' psSortOrder: "ASC", "DESC" or "" (= not sorted, default)
|
|
''' Return: a (0:1) array
|
|
''' (0) = True when found
|
|
''' (1) = if found: index of item
|
|
''' if not found: if sorted, index of next item in the array (might be = UBound + 1)
|
|
''' if not sorted, meaningless
|
|
''' Result is unpredictable when array is announced sorted and is in reality not
|
|
''' Called by Contains, IndexOf and InsertSorted. Also called by SF_Dictionary
|
|
|
|
Dim bContains As Boolean ' True if match found
|
|
Dim iToFindType As Integer ' VarType of pvToFind
|
|
Dim lTop As Long, lBottom As Long ' Interval in scope of binary search
|
|
Dim lIndex As Long ' Index used in search
|
|
Dim iCompare As Integer ' Output of _ValCompare function
|
|
Dim lLoops As Long ' Count binary searches
|
|
Dim lMaxLoops As Long ' Max number of loops during binary search: to avoid infinite loops if array not sorted
|
|
Dim vFound(1) As Variant ' Returned array (Contains, Index)
|
|
|
|
bContains = False
|
|
|
|
If LBound(pvArray_1D) > UBound(pvArray_1D) Then ' Empty array, do nothing
|
|
Else
|
|
' Search sequentially
|
|
If Len(psSortOrder) = 0 Then
|
|
For lIndex = LBound(pvArray_1D) To UBound(pvArray_1D)
|
|
bContains = ( SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive) = 0 )
|
|
If bContains Then Exit For
|
|
Next lIndex
|
|
Else
|
|
' Binary search
|
|
If psSortOrder = "ASC" Then
|
|
lTop = UBound(pvArray_1D)
|
|
lBottom = lBound(pvArray_1D)
|
|
Else
|
|
lBottom = UBound(pvArray_1D)
|
|
lTop = lBound(pvArray_1D)
|
|
End If
|
|
lLoops = 0
|
|
lMaxLoops = CLng((Log(UBound(pvArray_1D) - LBound(pvArray_1D) + 1.0) / Log(2.0))) + 1
|
|
Do
|
|
lLoops = lLoops + 1
|
|
lIndex = (lTop + lBottom) / 2
|
|
iCompare = SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive)
|
|
Select Case True
|
|
Case iCompare = 0 : bContains = True
|
|
Case iCompare < 0 And psSortOrder = "ASC"
|
|
lTop = lIndex - 1
|
|
Case iCompare > 0 And psSortOrder = "DESC"
|
|
lBottom = lIndex - 1
|
|
Case iCompare > 0 And psSortOrder = "ASC"
|
|
lBottom = lIndex + 1
|
|
Case iCompare < 0 And psSortOrder = "DESC"
|
|
lTop = lIndex + 1
|
|
End Select
|
|
Loop Until ( bContains ) Or ( lBottom > lTop And psSortOrder = "ASC" ) Or (lBottom < lTop And psSortOrder = "DESC" ) Or lLoops > lMaxLoops
|
|
' Flag first next non-matching element
|
|
If Not bContains Then lIndex = Iif(psSortOrder = "ASC", lBottom, lTop)
|
|
End If
|
|
End If
|
|
|
|
' Build output array
|
|
vFound(0) = bContains
|
|
vFound(1) = lIndex
|
|
_FindItem = vFound
|
|
|
|
End Function ' ScriptForge.SF_Array._FindItem
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _HeapSort(ByRef pvArray As Variant _
|
|
, Optional ByVal pbAscending As Boolean _
|
|
, Optional ByVal pbCaseSensitive As Boolean _
|
|
) As Variant
|
|
''' Sort an array: items are presumed all strings, all dates or all numeric
|
|
''' Null or Empty are allowed and are considered smaller than other items
|
|
''' https://en.wikipedia.org/wiki/Heapsort
|
|
''' http://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-(sort-array-sorting-arrays)&p=2909250#post2909250
|
|
''' HeapSort preferred to QuickSort because not recursive (this routine returns an array of indexes !!)
|
|
''' Args:
|
|
''' pvArray: a 1D array
|
|
''' pbAscending: default = True
|
|
''' pbCaseSensitive: default = False
|
|
''' Returns
|
|
''' An array of Longs of same dimensions as the input array listing the indexes of the sorted items
|
|
''' An empty array if the sort failed
|
|
''' Examples:
|
|
''' _HeapSort(Array(4, 2, 6, 1) returns (3, 1, 0, 2)
|
|
|
|
Dim vIndexes As Variant ' Return value
|
|
Dim i As Long
|
|
Dim lMin As Long, lMax As Long ' Array bounds
|
|
Dim lSwap As Long ' For index swaps
|
|
|
|
If IsMissing(pbAscending) Then pbAscending = True
|
|
If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
|
|
vIndexes = Array()
|
|
lMin = LBound(pvArray, 1)
|
|
lMax = UBound(pvArray, 1)
|
|
|
|
' Initialize output array
|
|
ReDim vIndexes(lMin To lMax)
|
|
For i = lMin To lMax
|
|
vIndexes(i) = i
|
|
Next i
|
|
|
|
' Initial heapify
|
|
For i = (lMax + lMin) \ 2 To lMin Step -1
|
|
SF_Array._HeapSort1(pvArray, vIndexes, i, lMin, lMax, pbCaseSensitive)
|
|
Next i
|
|
' Next heapify
|
|
For i = lMax To lMin + 1 Step -1
|
|
' Only indexes as swapped, not the array items themselves
|
|
lSwap = vIndexes(i)
|
|
vIndexes(i) = vIndexes(lMin)
|
|
vIndexes(lMin) = lSwap
|
|
SF_Array._HeapSort1(pvArray, vIndexes, lMin, lMin, i - 1, pbCaseSensitive)
|
|
Next i
|
|
|
|
If pbAscending Then _HeapSort = vIndexes() Else _HeapSort = SF_Array.Reverse(vIndexes())
|
|
|
|
End Function ' ScriptForge.SF_Array._HeapSort
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Sub _HeapSort1(ByRef pvArray As Variant _
|
|
, ByRef pvIndexes As Variant _
|
|
, ByVal plIndex As Long _
|
|
, ByVal plMin As Long _
|
|
, ByVal plMax As Long _
|
|
, ByVal pbCaseSensitive As Boolean _
|
|
)
|
|
''' Sub called by _HeapSort only
|
|
|
|
Dim lLeaf As Long
|
|
Dim lSwap As Long
|
|
|
|
Do
|
|
lLeaf = plIndex + plIndex - (plMin - 1)
|
|
Select Case lLeaf
|
|
Case Is > plMax: Exit Do
|
|
Case Is < plMax
|
|
If SF_Array._ValCompare(pvArray(pvIndexes(lLeaf + 1)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then lLeaf = lLeaf + 1
|
|
End Select
|
|
If SF_Array._ValCompare(pvArray(pvIndexes(plIndex)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then Exit Do
|
|
' Only indexes as swapped, not the array items themselves
|
|
lSwap = pvIndexes(plIndex)
|
|
pvIndexes(plIndex) = pvIndexes(lLeaf)
|
|
pvIndexes(lLeaf) = lSwap
|
|
plIndex = lLeaf
|
|
Loop
|
|
|
|
End Sub ' ScriptForge.SF_Array._HeapSort1
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _Repr(ByRef pvArray As Variant) As String
|
|
''' Convert array to a readable string, typically for debugging purposes (DebugPrint ...)
|
|
''' Args:
|
|
''' pvArray: the array to convert, individual items may be of any type, including arrays
|
|
''' Return:
|
|
''' "[ARRAY] (L:U[, L:U]...)" if # of Dims > 1
|
|
''' "[ARRAY] (L:U) (item1,item2, ...)" if 1D array
|
|
|
|
Dim iDims As Integer ' Number of dimensions of the array
|
|
Dim sArray As String ' Return value
|
|
Dim i As Long
|
|
Const cstArrayEmpty = "[ARRAY] ()"
|
|
Const cstArray = "[ARRAY]"
|
|
Const cstMaxLength = 50 ' Maximum length for items
|
|
Const cstSeparator = ", "
|
|
|
|
_Repr = ""
|
|
iDims = SF_Array.CountDims(pvArray)
|
|
|
|
Select Case iDims
|
|
Case -1 : Exit Function ' Not an array
|
|
Case 0 : sArray = cstArrayEmpty
|
|
Case Else
|
|
sArray = cstArray
|
|
For i = 1 To iDims
|
|
sArray = sArray & Iif(i = 1, " (", ", ") & CStr(LBound(pvArray, i)) & ":" & CStr(UBound(pvArray, i))
|
|
Next i
|
|
sArray = sArray & ")"
|
|
' List individual items of 1D arrays
|
|
If iDims = 1 Then
|
|
sArray = sArray & " ("
|
|
For i = LBound(pvArray) To UBound(pvArray)
|
|
sArray = sArray & SF_Utils._Repr(pvArray(i), cstMaxLength) & cstSeparator ' Recursive call
|
|
Next i
|
|
sArray = Left(sArray, Len(sArray) - Len(cstSeparator)) ' Suppress last comma
|
|
sArray = sArray & ")"
|
|
End If
|
|
End Select
|
|
|
|
_Repr = sArray
|
|
|
|
End Function ' ScriptForge.SF_Array._Repr
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function _StaticType(ByRef pvArray As Variant) As Integer
|
|
''' If array is static, return its type
|
|
''' Args:
|
|
''' pvArray: array to examine
|
|
''' Return:
|
|
''' array type, -1 if not identified
|
|
''' All numeric types are aggregated into V_NUMERIC
|
|
|
|
Dim iArrayType As Integer ' VarType of array
|
|
Dim iType As Integer ' VarType of items
|
|
|
|
iArrayType = VarType(pvArray)
|
|
iType = iArrayType - V_ARRAY
|
|
Select Case iType
|
|
Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL, V_BOOLEAN
|
|
_StaticType = V_NUMERIC
|
|
Case V_STRING, V_DATE
|
|
_StaticType = iType
|
|
Case Else
|
|
_StaticType = -1
|
|
End Select
|
|
|
|
End Function ' ScriptForge.SF_Utils._StaticType
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _ValCompare(ByVal pvValue1 As Variant _
|
|
, pvValue2 As Variant _
|
|
, Optional ByVal pbCaseSensitive As Boolean _
|
|
) As Integer
|
|
''' Compare 2 values : equality, greater than or smaller than
|
|
''' Args:
|
|
''' pvValue1 and pvValue2: values to compare. pvValues must be String, Number, Date, Empty or Null
|
|
''' By convention: Empty < Null < string, number or date
|
|
''' pbCaseSensitive: ignored when not String comparison
|
|
''' Return: -1 when pvValue1 < pvValue2
|
|
''' +1 when pvValue1 > pvValue2
|
|
''' 0 when pvValue1 = pvValue2
|
|
''' -2 when comparison is nonsense
|
|
|
|
Dim iCompare As Integer, iVarType1 As Integer, iVarType2 As Integer
|
|
|
|
If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
|
|
iVarType1 = SF_Utils._VarTypeExt(pvValue1)
|
|
iVarType2 = SF_Utils._VarTypeExt(pvValue2)
|
|
|
|
iCompare = -2
|
|
If iVarType1 = V_OBJECT Or iVarType1 = V_BYTE Or iVarType1 >= V_ARRAY Then ' Nonsense
|
|
ElseIf iVarType2 = V_OBJECT Or iVarType2 = V_BYTE Or iVarType2 >= V_ARRAY Then ' Nonsense
|
|
ElseIf iVarType1 = V_STRING And iVarType2 = V_STRING Then
|
|
iCompare = StrComp(pvValue1, pvValue2, Iif(pbCaseSensitive, 1, 0))
|
|
ElseIf iVarType1 = V_NULL Or iVarType1 = V_EMPTY Or iVarType2 = V_NULL Or iVarType2 = V_EMPTY Then
|
|
Select Case True
|
|
Case pvValue1 = pvValue2 : iCompare = 0
|
|
Case iVarType1 = V_NULL And iVarType2 = V_EMPTY : iCompare = +1
|
|
Case iVarType1 = V_EMPTY And iVarType2 = V_NULL : iCompare = -1
|
|
Case iVarType1 = V_NULL Or iVarType1 = V_EMPTY : iCompare = -1
|
|
Case iVarType2 = V_NULL Or iVarType2 = V_EMPTY : iCompare = +1
|
|
End Select
|
|
ElseIf iVarType1 = iVarType2 Then
|
|
Select Case True
|
|
Case pvValue1 < pvValue2 : iCompare = -1
|
|
Case pvValue1 = pvValue2 : iCompare = 0
|
|
Case pvValue1 > pvValue2 : iCompare = +1
|
|
End Select
|
|
End If
|
|
|
|
_ValCompare = iCompare
|
|
|
|
End Function ' ScriptForge.SF_Array._ValCompare
|
|
|
|
REM ================================================= END OF SCRIPTFORGE.SF_ARRAY
|
|
</script:module> |