wizards/source/scriptforge/SF_Array.xba | 2549 +++++++++++++++++++++
wizards/source/scriptforge/SF_Dictionary.xba | 952 +++++++
wizards/source/scriptforge/SF_Exception.xba | 1107 +++++++++
wizards/source/scriptforge/SF_FileSystem.xba | 2084 +++++++++++++++++
wizards/source/scriptforge/SF_L10N.xba | 696 +++++
wizards/source/scriptforge/SF_Platform.xba | 281 ++
wizards/source/scriptforge/SF_Root.xba | 822 ++++++
wizards/source/scriptforge/SF_Services.xba | 607 +++++
wizards/source/scriptforge/SF_Session.xba | 918 +++++++
wizards/source/scriptforge/SF_String.xba | 2642 ++++++++++++++++++++++
wizards/source/scriptforge/SF_TextStream.xba | 701 +++++
wizards/source/scriptforge/SF_Timer.xba | 463 +++
wizards/source/scriptforge/SF_UI.xba | 1175 +++++++++
wizards/source/scriptforge/SF_Utils.xba | 967 ++++++++
wizards/source/scriptforge/_CodingConventions.xba | 100
wizards/source/scriptforge/_ModuleModel.xba | 221 +
wizards/source/scriptforge/__License.xba | 25
wizards/source/scriptforge/dialog.xlb | 6
wizards/source/scriptforge/dlgConsole.xdl | 14
wizards/source/scriptforge/dlgProgress.xdl | 11
wizards/source/scriptforge/script.xlb | 21
21 files changed, 16362 insertions(+)
New commits:
commit 09c1bee1f91315fd7901af1804e028f6574228a6
Author: Jean-Pierre Ledure <j...@ledure.be>
AuthorDate: Thu Nov 5 15:55:39 2020 +0100
Commit: Jean-Pierre Ledure <j...@ledure.be>
CommitDate: Thu Nov 5 15:55:39 2020 +0100
ScriptForge - core library
Additional "LibreOffice Macros & Dialogs" library
Change-Id: I7380cf3f9ee56b73cfcf7b9e33d0cf50ecb40429
diff --git a/wizards/source/scriptforge/SF_Array.xba
b/wizards/source/scriptforge/SF_Array.xba
new file mode 100644
index 000000000000..914f42269867
--- /dev/null
+++ b/wizards/source/scriptforge/SF_Array.xba
@@ -0,0 +1,2549 @@
+<?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
+'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+
+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/DESCTRUCTOR
+
+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 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 =
unitialized array, else >= 1
+''' Examples:
+''' Dim a(1 To 10, -3 To 12, 5)
+''' CountDims(a) returns 3
+
+Dim iDims As Integer ' Return value
+Dim lMax As Long ' Storage for UBound of each dimension
+Const cstThisSub = "Array.CountDims"
+Const cstSubArgs = "Array_ND"
+
+Check:
+ iDims = -1
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If IsMissing(Array_ND) Then ' To have missing
exception processed
+ If Not SF_Utils._ValidateArray(Array_ND,
"Array_ND") Then GoTo Finally
+ End If
+ End If
+
+Try:
+ On Local Error Goto ErrHandler
+ ' Loop, increasing the dimension index (i) until an error occurs.
+ ' An error will occur when i exceeds the number of dimensions in
the array. Returns i - 1.
+ iDims = 0
+ If Not IsArray(Array_ND) Then
+ Else
+ Do
+ iDims = iDims + 1
+ lMax = UBound(Array_ND, iDims)
+ Loop Until (Err <> 0)
+ End If
+
+ ErrHandler:
+ On Local Error GoTo 0
+
+ iDims = iDims - 1
+ If iDims = 1 Then
+ If LBound(Array_ND, 1) > UBound(Array_ND, 1) Then iDims = 0
+ End If
+
+Finally:
+ CountDims = iDims
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+End Function ' ScriptForge.SF_Array.CountDims
+
+REM
-----------------------------------------------------------------------------
+Public Function Difference(Optional ByRef Array1_1D As Variant _
+ , Optional
ByRef Array2_1D As Variant _
+ , Optional
ByVal CaseSensitive As Variant _
+ ) As Variant
+''' Build a set being the Difference of the two input
arrays, i.e. items are contained in 1st array and NOT in 2nd
+''' both input arrays must be filled homogeneously,
i.e. all items must be of the same type
+''' Empty and Null items are forbidden
+''' The comparison between strings is case
sensitive or not
+''' Args:
+''' Array1_1D: a 1st input array
+''' Array2_1D: a 2nd input array
+''' CaseSensitive: default = False
+''' Returns: a zero-based array containing unique items
from the 1st array not present in the 2nd
+''' The output array is sorted in ascending order
+''' Examples:
+''' SF_Array.Difference(Array("A",
"C", "A", "b", "B"),
Array("C", "Z", "b"), True) returns
("A", "B")
+
+Dim vDifference() As Variant ' Return value
+Dim vSorted() As Variant ' The 2nd input array after sort
+Dim iType As Integer ' VarType of elements in input
arrays
+Dim lMin1 As Long ' LBound of 1st input
array
+Dim lMax1 As Long ' UBound of 1st input
array
+Dim lMin2 As Long ' LBound of 2nd input
array
+Dim lMax2 As Long ' UBound of 2nd input
array
+Dim lSize As Long ' Number of Difference
items
+Dim vItem As Variant ' One single item in the array
+Dim i As Long
+Const cstThisSub = "Array.Difference"
+Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ vDifference = Array()
+
+Check:
+ If IsMissing(CaseSensitive) Then CaseSensitive = False
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateArray(Array1_1D,
"Array1_1D", 1, 0, True) Then GoTo Finally
+ iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
+ If Not SF_Utils._ValidateArray(Array2_1D,
"Array2_1D", 1, iType, True) Then GoTo Finally
+ If Not SF_Utils._Validate(CaseSensitive,
"CaseSensitive", V_BOOLEAN) Then GoTo Finally
+ End If
+
+Try:
+ lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
+ lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
+
+ ' If 1st array is empty, do nothing
+ If lMax1 < lMin1 Then
+ ElseIf lMax2 < lMin2 Then ' only 2nd array is empty
+ vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
+ Else
+
+ ' First sort the 2nd array
+ vSorted = SF_Array.Sort(Array2_1D, "ASC",
CaseSensitive)
+
+ ' Resize the output array to the size of the 1st array
+ ReDim vDifference(0 To (lMax1 - lMin1))
+ lSize = -1
+
+ ' Fill vDifference one by one with items present only in
1st set
+ For i = lMin1 To lMax1
+ vItem = Array1_1D(i)
+ If Not SF_Array.Contains(vSorted, vItem, CaseSensitive,
"ASC") Then
+ lSize = lSize + 1
+ vDifference(lSize) = vItem
+ End If
+ Next i
+
+ ' Remove unfilled entries and duplicates
+ If lSize >= 0 Then
+ ReDim Preserve vDifference(0 To lSize)
+ vDifference() = SF_Array.Unique(vDifference,
CaseSensitive)
+ Else
+ vDifference = Array()
+ End If
+ End If
+
+Finally:
+ Difference = vDifference()
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.Difference
+
+REM
-----------------------------------------------------------------------------
+Public Function ExportToTextFile(Optional ByRef Array_1D As Variant _
+ ,
Optional ByVal FileName As Variant _
+ ,
Optional ByVal Encoding As Variant _
+ ) As
Boolean
+''' Write all items of the array sequentially to a text file
+''' If the file exists already, it will be overwritten
without warning
+''' Args:
+''' Array_1D: the array to export
+''' FileName: the full name (path + file) in
SF_FileSystem.FileNaming notation
+''' Encoding: The character set that should be used
+''' Use one of the Names listed in
https://www.iana.org/assignments/character-sets/character-sets.xhtml
+''' Note that LibreOffice does not
implement all existing sets
+''' Default = UTF-8
+''' Returns:
+''' True if successful
+''' Examples:
+'''
SF_Array.ExportToTextFile(Array("A","B","C","D"),
"C:\Temp\A short file.txt")
+
+Dim bExport As Boolean ' Return value
+Dim oFile As Object ' Output file handler
+Dim sLine As String ' A single line
+Const cstThisSub = "Array.ExportToTextFile"
+Const cstSubArgs = "Array_1D, FileName"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ bExport = False
+
+Check:
+ If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding =
"UTF-8"
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateArray(Array_1D, "Array_1D",
1, V_STRING, True) Then GoTo Finally
+ If Not SF_Utils._ValidateFile(FileName, "FileName")
Then GoTo Finally
+ If Not SF_Utils._Validate(Encoding, "Encoding",
V_STRING) Then GoTo Finally
+ End If
+
+Try:
+ Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True,
Encoding := Encoding)
+ If Not IsNull(oFile) Then
+ With oFile
+ For Each sLine In Array_1D
+ .WriteLine(sLine)
+ Next sLine
+ .CloseFile()
+ End With
+ End If
+
+ bExport = True
+
+Finally:
+ If Not IsNull(oFile) Then Set oFile = oFile.Dispose()
+ ExportToTextFile = bExport
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.ExportToTextFile
+
+REM
-----------------------------------------------------------------------------
+Public Function ExtractColumn(Optional ByRef Array_2D As Variant _
+ , Optional
ByVal ColumnIndex As Variant _
+ ) As Variant
+''' ExtractColumn extracts from a 2D array a specific column
+''' Args
+''' Array_2D: the array from which to extract
+''' ColumnIndex: the column to extract - must be in
the interval [LBound, UBound]
+''' Returns:
+''' the extracted column. Its LBound and UBound are
identical to that of the 1st dimension of Array_2D
+''' Exceptions:
+''' ARRAYINDEX1ERROR
+''' Examples:
+'''
|1, 2, 3|
+''' SF_Array.ExtractColumn( |4, 5, 6|, 2) returns
(3, 6, 9)
+'''
|7, 8, 9|
+
+Dim vExtractColumn As Variant ' Return value
+Dim lMin1 As Long ' LBound1 of input array
+Dim lMax1 As Long ' UBound1 of input array
+Dim lMin2 As Long ' LBound1 of input array
+Dim lMax2 As Long ' UBound1 of input array
+Dim i As Long
+Const cstThisSub = "Array.ExtractColumn"
+Const cstSubArgs = "Array_2D, ColumnIndex"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ vExtractColumn = Array()
+
+Check:
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateArray(Array_2D, "Array_2D",
2) Then GoTo Finally
+ If Not SF_Utils._Validate(ColumnIndex, "ColumnIndex",
V_NUMERIC) Then GoTo Finally
+ End If
+
+Try:
+ ' Compute future dimensions of output array
+ lMin2 = LBound(Array_2D, 2) : lMax2 =
UBound(Array_2D, 2)
+ If ColumnIndex < lMin2 Or ColumnIndex > lMax2 Then GoTo CatchIndex
+ lMin1 = LBound(Array_2D, 1) : lMax1 =
UBound(Array_2D, 1)
+ ReDim vExtractColumn(lMin1 To lMax1)
+
+ ' Copy Column of input array to output array
+ For i = lMin1 To lMax1
+ vExtractColumn(i) = Array_2D(i, ColumnIndex)
+ Next i
+
+Finally:
+ ExtractColumn = vExtractColumn()
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+CatchIndex:
+ SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "ColumnIndex",
SF_Array._Repr(Array_2D), ColumnIndex)
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.ExtractColumn
+
+REM
-----------------------------------------------------------------------------
+Public Function ExtractRow(Optional ByRef Array_2D As Variant _
+ , Optional ByVal
RowIndex As Variant _
+ ) As Variant
+''' ExtractRow extracts from a 2D array a specific row
+''' Args
+''' Array_2D: the array from which to extract
+''' RowIndex: the row to extract - must be in the
interval [LBound, UBound]
+''' Returns:
+''' the extracted row. Its LBound and UBound are
identical to that of the 2nd dimension of Array_2D
+''' Exceptions:
+''' ARRAYINDEX1ERROR
+''' Examples:
+''' |1, 2,
3|
+''' SF_Array.ExtractRow(|4, 5, 6|, 2) returns (7,
8, 9)
+''' |7, 8,
9|
+
+Dim vExtractRow As Variant ' Return value
+Dim lMin1 As Long ' LBound1 of input array
+Dim lMax1 As Long ' UBound1 of input array
+Dim lMin2 As Long ' LBound1 of input array
+Dim lMax2 As Long ' UBound1 of input array
+Dim i As Long
+Const cstThisSub = "Array.ExtractRow"
+Const cstSubArgs = "Array_2D, RowIndex"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ vExtractRow = Array()
+
+Check:
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateArray(Array_2D, "Array_2D",
2) Then GoTo Finally
+ If Not SF_Utils._Validate(RowIndex, "RowIndex",
V_NUMERIC) Then GoTo Finally
+ End If
+
+Try:
+ ' Compute future dimensions of output array
+ lMin1 = LBound(Array_2D, 1) : lMax1 =
UBound(Array_2D, 1)
+ If RowIndex < lMin1 Or RowIndex > lMax1 Then GoTo CatchIndex
+ lMin2 = LBound(Array_2D, 2) : lMax2 =
UBound(Array_2D, 2)
+ ReDim vExtractRow(lMin2 To lMax2)
+
+ ' Copy row of input array to output array
+ For i = lMin2 To lMax2
+ vExtractRow(i) = Array_2D(RowIndex, i)
+ Next i
+
+Finally:
+ ExtractRow = vExtractRow()
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+CatchIndex:
+ SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "RowIndex",
SF_Array._Repr(Array_2D), RowIndex)
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.ExtractRow
+
+REM
-----------------------------------------------------------------------------
+Public Function Flatten(Optional ByRef Array_1D As Variant) As Variant
+''' Stack all items and all items in subarrays into one
array without subarrays
+''' Args
+''' Array_1D: the pre-existing array, may be empty
+''' Return:
+''' The new flattened array. Its LBound is
identical to that of Array_1D
+''' If one of the subarrays has a number of
dimensions > 1 Then that subarray is left unchanged
+''' Examples:
+''' SF_Array.Flatten(Array(1, 2, Array(3, 4, 5))
returns (1, 2, 3, 4, 5)
+
+Dim vFlatten As Variant ' Return value
+Dim lMin As Long ' LBound of input array
+Dim lMax As Long ' UBound of input array
+Dim lIndex As Long ' Index in output array
+Dim vItem As Variant ' Array single item
+Dim iDims As Integer ' Array number of dimensions
+Dim lEmpty As Long ' Number of empty subarrays
+Dim i As Long
+Dim j As Long
+Const cstThisSub = "Array.Flatten"
+Const cstSubArgs = "Array_1D"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ vFlatten = Array()
+
+Check:
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateArray(Array_1D, "Array_1D",
1) Then GoTo Finally
+ End If
+
+Try:
+ If UBound(Array_1D) >= LBound(Array_1D) Then
+ lMin = LBound(Array_1D) : lMax = UBound(Array_1D)
+ ReDim vFlatten(lMin To lMax) ' Initial minimal sizing
+ lEmpty = 0
+ lIndex = lMin - 1
+ For i = lMin To lMax
+ vItem = Array_1D(i)
+ If IsArray(vItem) Then
+ iDims = SF_Array.CountDims(vItem)
+ Select Case iDims
+ Case 0 ' Empty
arrays are ignored
+ lEmpty = lEmpty + 1
+ Case 1 ' Only 1D
subarrays are flattened
+ ReDim Preserve vFlatten(lMin To
UBound(vFlatten) + UBound(vItem) - LBound(vItem))
+ For j = LBound(vItem) To
UBound(vItem)
+ lIndex = lIndex + 1
+ vFlatten(lIndex) =
vItem(j)
+ Next j
+ Case > 1 ' Other
arrays are left unchanged
+ lIndex = lIndex + 1
+ vFlatten(lIndex) = vItem
+ End Select
+ Else
+ lIndex = lIndex + 1
+ vFlatten(lIndex) = vItem
+ End If
+ Next i
+ End If
+ ' Reduce size of output if Array_1D is populated with some empty
arrays
+ If lEmpty > 0 Then
+ If lIndex - lEmpty < lMin Then
+ vFlatten = Array()
+ Else
+ ReDim Preserve vFlatten(lMin To UBound(vFlatten) -
lEmpty)
+ End If
+ End If
+
+Finally:
+ Flatten = vFlatten()
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.Flatten
+
+REM
-----------------------------------------------------------------------------
+Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
+''' Return the actual value of the given property
+''' Args:
+''' PropertyName: the name of the property as a
string
+''' Returns:
+''' The actual value of the property
+''' Exceptions
+''' ARGUMENTERROR The property does not
exist
+
+Const cstThisSub = "Array.GetProperty"
+Const cstSubArgs = "PropertyName"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ GetProperty = Null
+
+Check:
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._Validate(PropertyName,
"PropertyName", V_STRING, Properties()) Then GoTo Catch
+ End If
+
+Try:
+ Select Case UCase(PropertyName)
+ Case Else
+ End Select
+
+Finally:
+ SF_Utils._ExitFunction(cstThisSub)
+ Exit Function
+Catch:
+ GoTo Finally
+End Function ' ScriptForge.SF_Array.GetProperty
+
+REM
-----------------------------------------------------------------------------
+Public Function ImportFromCSVFile(Optional ByRef FileName As Variant _
+ ,
Optional ByVal Delimiter As Variant _
+ ,
Optional ByVal DateFormat As Variant _
+ ) As
Variant
+''' Import the data contained in a comma-separated values
(CSV) file
+''' The comma may be replaced by any character
+''' Each line in the file contains a full record
+''' Line splitting is not allowed)
+''' However sequences like \n, \t, ... are left
unchanged. Use SF_String.Unescape() to manage them
+''' A special mechanism is implemented to load dates
+''' The applicable CSV format is described in
https://tools.ietf.org/html/rfc4180
+''' Args:
+''' FileName: the name of the text file containing
the data expressed as given by the current FileNaming
+''' property of the SF_FileSystem service.
Default = both URL format or native format
+''' Delimiter: Default = ",". Other
usual options are ";" and the tab character
+''' DateFormat: either YYYY-MM-DD, DD-MM-YYYY or
MM-DD-YYYY
+''' The dash (-) may be replaced by a dot
(.), a slash (/) or a space
+''' Other date formats will be ignored
+''' If "" (default), dates will
be considered as strings
+''' Returns:
+''' A 2D-array with each row corresponding with a
single record read in the file
+''' and each column corresponding with a field of
the record
+''' No check is made about the coherence of the
field types across columns
+''' A best guess will be made to identify
numeric and date types
+''' If a line contains less or more fields than the
first line in the file,
+''' an exception will be raised. Empty
lines however are simply ignored
+''' If the size of the file exceeds the number of
items limit, a warning is raised
+''' and the array is truncated
+''' Exceptions:
+''' CSVPARSINGERROR Given file is not
formatted as a csv file
+''' CSVOVERFLOWWARNING Maximum number of
allowed items exceeded
+
+Dim vArray As Variant ' Returned array
+Dim lCol As Long ' Index of last column of
vArray
+Dim lRow As Long ' Index of current row of
vArray
+Dim lFileSize As Long ' Number of records found in the
file
+Dim vCsv As Object ' CSV file handler
+Dim sLine As String ' Last read line
+Dim vLine As Variant ' Array of fields of last read
line
+Dim sItem As String ' Individual item in the
file
+Dim vItem As Variant ' Individual item in the output
array
+Dim iPosition As Integer ' Date position in individual item
+Dim iYear As Integer, iMonth As Integer, iDay As Integer
+ ' Date
components
+Dim i As Long
+Const cstItemsLimit = 250000 ' Maximum number of admitted items
+Const cstThisSub = "Array.ImportFromCSVFile"
+Const cstSubArgs = "FileName, [Delimiter="",""],
[DateFormat=""""]"
+
+ If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
+ vArray = Array()
+
+Check:
+ If IsMissing(Delimiter) Or IsEmpty(Delimiter) Then Delimiter =
","
+ If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat =
""
+ If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
+ If Not SF_Utils._ValidateFile(FileName, "FileName")
Then GoTo Finally
+ If Not SF_Utils._Validate(Delimiter, "Delimiter",
V_STRING) Then GoTo Finally
+ If Not SF_Utils._Validate(DateFormat, "DateFormat",
V_STRING) Then GoTo Finally
+ End If
+ If Len(Delimiter) = 0 Then Delimiter = ","
+
+Try:
+ ' 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
+ ' Interprete 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)
+ 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
... etc. - the rest is truncated
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
https://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
