diff options
Diffstat (limited to 'wizards/source/scriptforge/SF_Array.xba')
| -rw-r--r-- | wizards/source/scriptforge/SF_Array.xba | 2608 |
1 files changed, 2608 insertions, 0 deletions
diff --git a/wizards/source/scriptforge/SF_Array.xba b/wizards/source/scriptforge/SF_Array.xba new file mode 100644 index 000000000..49bdab147 --- /dev/null +++ b/wizards/source/scriptforge/SF_Array.xba @@ -0,0 +1,2608 @@ +<?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, SortOrder)(0) + +Finally: + Contains = bContains + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Contains + +REM ----------------------------------------------------------------------------- +Public Function ConvertToDictionary(Optional ByRef Array_2D As Variant) As Variant +''' Store the content of a 2-columns array into a dictionary +''' 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 = "Dictionary.ConvertToArray" +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") + 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 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 _ + , Optional ByVal _IsoDate 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 +''' _IsoDate: when True, the execution is initiated from Python, do not convert dates to Date variables. Internal use only +''' 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 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 IsMissing(_IsoDate) Or IsEmpty(_IsoDate) Then _IsoDate = False + 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: + ' 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 _IsoDate 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, 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, 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)) + 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) + vIndexes() = SF_Array._HeapSort(Array_1D, ( 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, ( 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, ( 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 ----------------------------------------------------------------------------- +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>
\ No newline at end of file |