| blob | 49bdab14770a189da94d1f819c42f5bee8cd8766 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Array" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === Full documentation is available on https://help.libreoffice.org/ ===
6 REM =======================================================================================================================
8 Option Compatible
9 Option Explicit
11 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
12 ''' SF_Array
13 ''' ========
15 ''' Implemented as a usual Basic module
16 ''' Only 1D or 2D arrays are considered. Arrays with more than 2 dimensions are rejected
18 ''' The first argument of almost every method is the array to consider
19 ''' It is always passed by reference and left unchanged
20 '''
21 ''' Detailed user documentation:
22 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_array.html?DbPAR=BASIC
23 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
25 REM ================================================================== EXCEPTIONS
28 Const ARRAYINSERTERROR = "ARRAYINSERTERROR" ' Matrix and vector have incompatible sizes
29 Const ARRAYINDEX1ERROR = "ARRAYINDEX1ERROR" ' Given index does not fit in array bounds
30 Const ARRAYINDEX2ERROR = "ARRAYINDEX2ERROR" ' Given indexes do not fit in array bounds
31 Const CSVPARSINGERROR = "CSVPARSINGERROR" ' Parsing error detected while parsing a csv file
32 Const CSVOVERFLOWWARNING = "CSVOVERFLOWWARNING" ' Array becoming too big, import process of csv file is interrupted
34 REM ============================================================ MODULE CONSTANTS
38 REM ===================================================== CONSTRUCTOR/DESTRUCTOR
40 REM -----------------------------------------------------------------------------
41 Public Function Dispose() As Variant
42 Set Dispose = Nothing
43 End Function ' ScriptForge.SF_Array Explicit destructor
45 REM ================================================================== PROPERTIES
47 REM -----------------------------------------------------------------------------
48 Property Get ObjectType As String
49 ''' Only to enable object representation
51 End Property ' ScriptForge.SF_Array.ObjectType
53 REM -----------------------------------------------------------------------------
54 Property Get ServiceName As String
55 ''' Internal use
57 End Property ' ScriptForge.SF_Array.ServiceName
59 REM ============================================================== PUBLIC METHODS
61 REM -----------------------------------------------------------------------------
62 Public Function Append(Optional ByRef Array_1D As Variant _
63 , ParamArray pvArgs() As Variant _
64 ) As Variant
65 ''' Append at the end of the input array the items listed as arguments
66 ''' Arguments are appended blindly
67 ''' each of them might be a scalar of any type or a subarray
68 ''' Args
69 ''' Array_1D: the pre-existing array, may be empty
70 ''' pvArgs: a list of items to append to Array_1D
71 ''' Return:
72 ''' the new extended array. Its LBound is identical to that of Array_1D
73 ''' Examples:
76 Dim vAppend As Variant ' Return value
77 Dim lNbArgs As Long ' Number of elements to append
78 Dim lMax As Long ' UBound of input array
79 Dim i As Long
83 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
84 vAppend = Array()
86 Check:
87 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
89 End If
91 Try:
92 lMax = UBound(Array_1D)
97 End If
98 Else
99 vAppend() = Array_1D()
101 ReDim Preserve vAppend(LBound(Array_1D) To lMax + lNbArgs)
102 End If
103 End If
104 For i = 1 To lNbArgs
105 vAppend(lMax + i) = pvArgs(i - 1)
106 Next i
108 Finally:
109 Append = vAppend()
110 SF_Utils._ExitFunction(cstThisSub)
111 Exit Function
112 Catch:
113 GoTo Finally
114 End Function ' ScriptForge.SF_Array.Append
116 REM -----------------------------------------------------------------------------
117 Public Function AppendColumn(Optional ByRef Array_2D As Variant _
118 , Optional ByRef Column As Variant _
119 ) As Variant
121 ''' Args
122 ''' Array_2D: the pre-existing array, may be empty
123 ''' If the array has 1 dimension, it is considered as the 1st Column of the resulting 2D array
125 ''' Returns:
126 ''' the new extended array. Its LBounds are identical to that of Array_2D
127 ''' Exceptions:
128 ''' ARRAYINSERTERROR
129 ''' Examples:
130 ''' SF_Array.AppendColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 4), (2, 5), (3, 6))
131 ''' x = SF_Array.AppendColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
133 Dim vAppendColumn As Variant ' Return value
134 Dim iDims As Integer ' Dimensions of Array_2D
135 Dim lMin1 As Long ' LBound1 of input array
136 Dim lMax1 As Long ' UBound1 of input array
137 Dim lMin2 As Long ' LBound2 of input array
138 Dim lMax2 As Long ' UBound2 of input array
139 Dim lMin As Long ' LBound of Column array
140 Dim lMax As Long ' UBound of Column array
141 Dim i As Long
142 Dim j As Long
146 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
147 vAppendColumn = Array()
149 Check:
150 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
151 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
153 End If
154 iDims = SF_Array.CountDims(Array_2D)
156 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
157 End If
159 Try:
160 lMin = LBound(Column)
161 lMax = UBound(Column)
163 ' Compute future dimensions of output array
164 Select Case iDims
165 Case 0 : lMin1 = lMin : lMax1 = lMax
171 End Select
173 ReDim vAppendColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
175 ' Copy input array to output array
176 For i = lMin1 To lMax1
177 For j = lMin2 To lMax2
178 If iDims = 2 Then vAppendColumn(i, j) = Array_2D(i, j) Else vAppendColumn(i, j) = Array_2D(i)
179 Next j
180 Next i
181 ' Copy new Column
182 For i = lMin1 To lMax1
183 vAppendColumn(i, lMax2 + 1) = Column(i)
184 Next i
186 Finally:
187 AppendColumn = vAppendColumn()
188 SF_Utils._ExitFunction(cstThisSub)
189 Exit Function
190 Catch:
191 GoTo Finally
192 CatchColumn:
193 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
194 GoTo Finally
195 End Function ' ScriptForge.SF_Array.AppendColumn
197 REM -----------------------------------------------------------------------------
198 Public Function AppendRow(Optional ByRef Array_2D As Variant _
199 , Optional ByRef Row As Variant _
200 ) As Variant
202 ''' Args
203 ''' Array_2D: the pre-existing array, may be empty
204 ''' If the array has 1 dimension, it is considered as the 1st row of the resulting 2D array
206 ''' Returns:
207 ''' the new extended array. Its LBounds are identical to that of Array_2D
208 ''' Exceptions:
209 ''' ARRAYINSERTERROR
210 ''' Examples:
211 ''' SF_Array.AppendRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 2, 3), (4, 5, 6))
212 ''' x = SF_Array.AppendRow(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
214 Dim vAppendRow As Variant ' Return value
215 Dim iDims As Integer ' Dimensions of Array_2D
216 Dim lMin1 As Long ' LBound1 of input array
217 Dim lMax1 As Long ' UBound1 of input array
218 Dim lMin2 As Long ' LBound2 of input array
219 Dim lMax2 As Long ' UBound2 of input array
220 Dim lMin As Long ' LBound of row array
221 Dim lMax As Long ' UBound of row array
222 Dim i As Long
223 Dim j As Long
227 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
228 vAppendRow = Array()
230 Check:
231 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
232 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
234 End If
235 iDims = SF_Array.CountDims(Array_2D)
237 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
238 End If
240 Try:
241 lMin = LBound(Row)
242 lMax = UBound(Row)
244 ' Compute future dimensions of output array
245 Select Case iDims
247 lMin2 = lMin : lMax2 = lMax
252 End Select
254 ReDim vAppendRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
256 ' Copy input array to output array
257 For i = lMin1 To lMax1
258 For j = lMin2 To lMax2
259 If iDims = 2 Then vAppendRow(i, j) = Array_2D(i, j) Else vAppendRow(i, j) = Array_2D(j)
260 Next j
261 Next i
262 ' Copy new row
263 For j = lMin2 To lMax2
264 vAppendRow(lMax1 + 1, j) = Row(j)
265 Next j
267 Finally:
268 AppendRow = vAppendRow()
269 SF_Utils._ExitFunction(cstThisSub)
270 Exit Function
271 Catch:
272 GoTo Finally
273 CatchRow:
274 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
275 GoTo Finally
276 End Function ' ScriptForge.SF_Array.AppendRow
278 REM -----------------------------------------------------------------------------
279 Public Function Contains(Optional ByRef Array_1D As Variant _
280 , Optional ByVal ToFind As Variant _
281 , Optional ByVal CaseSensitive As Variant _
282 , Optional ByVal SortOrder As Variant _
283 ) As Boolean
285 ''' The comparison between strings can be done case-sensitive or not
286 ''' If the array is sorted then
287 ''' the array must be filled homogeneously, i.e. all items must be of the same type
288 ''' Empty and Null items are forbidden
289 ''' a binary search is done
290 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
291 ''' Args:
292 ''' Array_1D: the array to scan
293 ''' ToFind: a number, a date or a string to find
294 ''' CaseSensitive: Only for string comparisons, default = False
295 ''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
296 ''' Return: True when found
297 ''' Result is unpredictable when array is announced sorted and is in reality not
298 ''' Examples:
299 ''' SF_Array.Contains(Array("A","B","c","D"), "C", SortOrder := "ASC") returns True
300 ''' SF_Array.Contains(Array("A","B","c","D"), "C", CaseSensitive := True) returns False
302 Dim bContains As Boolean ' Return value
303 Dim iToFindType As Integer ' VarType of ToFind
305 Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
307 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
309 bContains = False
311 Check:
312 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
313 If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
314 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
315 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
316 If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
317 iToFindType = SF_Utils._VarTypeExt(ToFind)
318 If SortOrder <> "" Then
319 If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, iToFindType) Then GoTo Finally
320 Else
322 End If
323 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
324 End If
326 Try:
327 bContains = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder)(0)
329 Finally:
330 Contains = bContains
331 SF_Utils._ExitFunction(cstThisSub)
332 Exit Function
333 Catch:
334 GoTo Finally
335 End Function ' ScriptForge.SF_Array.Contains
337 REM -----------------------------------------------------------------------------
338 Public Function ConvertToDictionary(Optional ByRef Array_2D As Variant) As Variant
341 ''' Args:
344 ''' Returns:
345 ''' a ScriptForge dictionary object
346 ''' Examples:
347 '''
349 Dim oDict As Variant ' Return value
350 Dim i As Long
354 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
356 Check:
357 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
358 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2, V_STRING, True) Then GoTo Finally
359 End If
361 Try:
365 Next i
367 ConvertToDictionary = oDict
369 Finally:
370 SF_Utils._ExitFunction(cstThisSub)
371 Exit Function
372 Catch:
373 GoTo Finally
374 End Function ' ScriptForge.SF_Array.ConvertToDictionary
376 REM -----------------------------------------------------------------------------
377 Public Function Copy(Optional ByRef Array_ND As Variant) As Variant
379 ''' A usual assignment copies an array by reference, i.e. shares the same memory location
380 ''' Dim a, b
382 ''' b = a
385 ''' Args
386 ''' Array_ND: the array to copy, may be empty
387 ''' Return:
388 ''' the copied array. Subarrays however still remain assigned by reference
389 ''' Examples:
392 Dim vCopy As Variant ' Return value
393 Dim iDims As Integer ' Number of dimensions of the input array
397 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
398 vCopy = Array()
400 Check:
401 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
403 iDims = SF_Array.CountDims(Array_ND)
406 End If
407 End If
409 Try:
410 Select Case iDims
411 Case 0
412 Case 1
413 vCopy = Array_ND
414 ReDim Preserve vCopy(LBound(Array_ND) To UBound(Array_ND))
415 Case 2
416 vCopy = Array_ND
417 ReDim Preserve vCopy(LBound(Array_ND, 1) To UBound(Array_ND, 1), LBound(Array_ND, 2) To UBound(Array_ND, 2))
418 End Select
420 Finally:
421 Copy = vCopy()
422 SF_Utils._ExitFunction(cstThisSub)
423 Exit Function
424 Catch:
425 GoTo Finally
426 End Function ' ScriptForge.SF_Array.Copy
428 REM -----------------------------------------------------------------------------
429 Public Function CountDims(Optional ByRef Array_ND As Variant) As Integer
431 ''' Args:
432 ''' Array_ND: the array to be examined
433 ''' Return: the number of dimensions: -1 = not array, 0 = uninitialized array, else >= 1
434 ''' Examples:
438 Dim iDims As Integer ' Return value
439 Dim lMax As Long ' Storage for UBound of each dimension
443 Check:
444 iDims = -1
445 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
446 If IsMissing(Array_ND) Then ' To have missing exception processed
448 End If
449 End If
451 Try:
452 On Local Error Goto ErrHandler
453 ' Loop, increasing the dimension index (i) until an error occurs.
455 iDims = 0
456 If Not IsArray(Array_ND) Then
457 Else
458 Do
459 iDims = iDims + 1
460 lMax = UBound(Array_ND, iDims)
462 End If
464 ErrHandler:
465 On Local Error GoTo 0
467 iDims = iDims - 1
468 If iDims = 1 Then
470 End If
472 Finally:
473 CountDims = iDims
474 SF_Utils._ExitFunction(cstThisSub)
475 Exit Function
476 End Function ' ScriptForge.SF_Array.CountDims
478 REM -----------------------------------------------------------------------------
479 Public Function Difference(Optional ByRef Array1_1D As Variant _
480 , Optional ByRef Array2_1D As Variant _
481 , Optional ByVal CaseSensitive As Variant _
482 ) As Variant
483 ''' Build a set being the Difference of the two input arrays, i.e. items are contained in 1st array and NOT in 2nd
484 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
485 ''' Empty and Null items are forbidden
486 ''' The comparison between strings is case sensitive or not
487 ''' Args:
490 ''' CaseSensitive: default = False
491 ''' Returns: a zero-based array containing unique items from the 1st array not present in the 2nd
492 ''' The output array is sorted in ascending order
493 ''' Examples:
494 ''' SF_Array.Difference(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B")
496 Dim vDifference() As Variant ' Return value
498 Dim iType As Integer ' VarType of elements in input arrays
503 Dim lSize As Long ' Number of Difference items
504 Dim vItem As Variant ' One single item in the array
505 Dim i As Long
509 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
510 vDifference = Array()
512 Check:
513 If IsMissing(CaseSensitive) Then CaseSensitive = False
514 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
516 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
517 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
518 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
519 End If
521 Try:
522 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
523 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
526 If lMax1 < lMin1 Then
528 vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
529 Else
535 ReDim vDifference(0 To (lMax1 - lMin1))
536 lSize = -1
539 For i = lMin1 To lMax1
540 vItem = Array1_1D(i)
542 lSize = lSize + 1
543 vDifference(lSize) = vItem
544 End If
545 Next i
547 ' Remove unfilled entries and duplicates
549 ReDim Preserve vDifference(0 To lSize)
550 vDifference() = SF_Array.Unique(vDifference, CaseSensitive)
551 Else
552 vDifference = Array()
553 End If
554 End If
556 Finally:
557 Difference = vDifference()
558 SF_Utils._ExitFunction(cstThisSub)
559 Exit Function
560 Catch:
561 GoTo Finally
562 End Function ' ScriptForge.SF_Array.Difference
564 REM -----------------------------------------------------------------------------
565 Public Function ExportToTextFile(Optional ByRef Array_1D As Variant _
566 , Optional ByVal FileName As Variant _
567 , Optional ByVal Encoding As Variant _
568 ) As Boolean
569 ''' Write all items of the array sequentially to a text file
570 ''' If the file exists already, it will be overwritten without warning
571 ''' Args:
572 ''' Array_1D: the array to export
573 ''' FileName: the full name (path + file) in SF_FileSystem.FileNaming notation
574 ''' Encoding: The character set that should be used
575 ''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml
576 ''' Note that LibreOffice does not implement all existing sets
578 ''' Returns:
579 ''' True if successful
580 ''' Examples:
581 ''' SF_Array.ExportToTextFile(Array("A","B","C","D"), "C:\Temp\A short file.txt")
583 Dim bExport As Boolean ' Return value
584 Dim oFile As Object ' Output file handler
585 Dim sLine As String ' A single line
589 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
590 bExport = False
592 Check:
594 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
595 If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, V_STRING, True) Then GoTo Finally
598 End If
600 Try:
601 Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True, Encoding := Encoding)
602 If Not IsNull(oFile) Then
603 With oFile
604 For Each sLine In Array_1D
605 .WriteLine(sLine)
606 Next sLine
607 .CloseFile()
608 End With
609 End If
611 bExport = True
613 Finally:
614 If Not IsNull(oFile) Then Set oFile = oFile.Dispose()
615 ExportToTextFile = bExport
616 SF_Utils._ExitFunction(cstThisSub)
617 Exit Function
618 Catch:
619 GoTo Finally
620 End Function ' ScriptForge.SF_Array.ExportToTextFile
622 REM -----------------------------------------------------------------------------
623 Public Function ExtractColumn(Optional ByRef Array_2D As Variant _
624 , Optional ByVal ColumnIndex As Variant _
625 ) As Variant
627 ''' Args
628 ''' Array_2D: the array from which to extract
629 ''' ColumnIndex: the column to extract - must be in the interval [LBound, UBound]
630 ''' Returns:
631 ''' the extracted column. Its LBound and UBound are identical to that of the 1st dimension of Array_2D
632 ''' Exceptions:
633 ''' ARRAYINDEX1ERROR
634 ''' Examples:
639 Dim vExtractColumn As Variant ' Return value
640 Dim lMin1 As Long ' LBound1 of input array
641 Dim lMax1 As Long ' UBound1 of input array
642 Dim lMin2 As Long ' LBound1 of input array
643 Dim lMax2 As Long ' UBound1 of input array
644 Dim i As Long
648 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
649 vExtractColumn = Array()
651 Check:
652 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
655 End If
657 Try:
658 ' Compute future dimensions of output array
662 ReDim vExtractColumn(lMin1 To lMax1)
664 ' Copy Column of input array to output array
665 For i = lMin1 To lMax1
666 vExtractColumn(i) = Array_2D(i, ColumnIndex)
667 Next i
669 Finally:
670 ExtractColumn = vExtractColumn()
671 SF_Utils._ExitFunction(cstThisSub)
672 Exit Function
673 Catch:
674 GoTo Finally
675 CatchIndex:
676 SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "ColumnIndex", SF_Array._Repr(Array_2D), ColumnIndex)
677 GoTo Finally
678 End Function ' ScriptForge.SF_Array.ExtractColumn
680 REM -----------------------------------------------------------------------------
681 Public Function ExtractRow(Optional ByRef Array_2D As Variant _
682 , Optional ByVal RowIndex As Variant _
683 ) As Variant
685 ''' Args
686 ''' Array_2D: the array from which to extract
687 ''' RowIndex: the row to extract - must be in the interval [LBound, UBound]
688 ''' Returns:
689 ''' the extracted row. Its LBound and UBound are identical to that of the 2nd dimension of Array_2D
690 ''' Exceptions:
691 ''' ARRAYINDEX1ERROR
692 ''' Examples:
697 Dim vExtractRow As Variant ' Return value
698 Dim lMin1 As Long ' LBound1 of input array
699 Dim lMax1 As Long ' UBound1 of input array
700 Dim lMin2 As Long ' LBound1 of input array
701 Dim lMax2 As Long ' UBound1 of input array
702 Dim i As Long
706 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
707 vExtractRow = Array()
709 Check:
710 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
713 End If
715 Try:
716 ' Compute future dimensions of output array
720 ReDim vExtractRow(lMin2 To lMax2)
722 ' Copy row of input array to output array
723 For i = lMin2 To lMax2
724 vExtractRow(i) = Array_2D(RowIndex, i)
725 Next i
727 Finally:
728 ExtractRow = vExtractRow()
729 SF_Utils._ExitFunction(cstThisSub)
730 Exit Function
731 Catch:
732 GoTo Finally
733 CatchIndex:
734 SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "RowIndex", SF_Array._Repr(Array_2D), RowIndex)
735 GoTo Finally
736 End Function ' ScriptForge.SF_Array.ExtractRow
738 REM -----------------------------------------------------------------------------
739 Public Function Flatten(Optional ByRef Array_1D As Variant) As Variant
740 ''' Stack all items and all items in subarrays into one array without subarrays
741 ''' Args
742 ''' Array_1D: the pre-existing array, may be empty
743 ''' Return:
744 ''' The new flattened array. Its LBound is identical to that of Array_1D
745 ''' If one of the subarrays has a number of dimensions > 1 Then that subarray is left unchanged
746 ''' Examples:
749 Dim vFlatten As Variant ' Return value
750 Dim lMin As Long ' LBound of input array
751 Dim lMax As Long ' UBound of input array
752 Dim lIndex As Long ' Index in output array
753 Dim vItem As Variant ' Array single item
754 Dim iDims As Integer ' Array number of dimensions
755 Dim lEmpty As Long ' Number of empty subarrays
756 Dim i As Long
757 Dim j As Long
761 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
762 vFlatten = Array()
764 Check:
765 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
767 End If
769 Try:
770 If UBound(Array_1D) >= LBound(Array_1D) Then
771 lMin = LBound(Array_1D) : lMax = UBound(Array_1D)
772 ReDim vFlatten(lMin To lMax) ' Initial minimal sizing
773 lEmpty = 0
774 lIndex = lMin - 1
775 For i = lMin To lMax
776 vItem = Array_1D(i)
777 If IsArray(vItem) Then
778 iDims = SF_Array.CountDims(vItem)
779 Select Case iDims
781 lEmpty = lEmpty + 1
783 ReDim Preserve vFlatten(lMin To UBound(vFlatten) + UBound(vItem) - LBound(vItem))
784 For j = LBound(vItem) To UBound(vItem)
785 lIndex = lIndex + 1
786 vFlatten(lIndex) = vItem(j)
787 Next j
789 lIndex = lIndex + 1
790 vFlatten(lIndex) = vItem
791 End Select
792 Else
793 lIndex = lIndex + 1
794 vFlatten(lIndex) = vItem
795 End If
796 Next i
797 End If
798 ' Reduce size of output if Array_1D is populated with some empty arrays
800 If lIndex - lEmpty < lMin Then
801 vFlatten = Array()
802 Else
803 ReDim Preserve vFlatten(lMin To UBound(vFlatten) - lEmpty)
804 End If
805 End If
807 Finally:
808 Flatten = vFlatten()
809 SF_Utils._ExitFunction(cstThisSub)
810 Exit Function
811 Catch:
812 GoTo Finally
813 End Function ' ScriptForge.SF_Array.Flatten
815 REM -----------------------------------------------------------------------------
816 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
817 ''' Return the actual value of the given property
818 ''' Args:
819 ''' PropertyName: the name of the property as a string
820 ''' Returns:
821 ''' The actual value of the property
822 ''' Exceptions
823 ''' ARGUMENTERROR The property does not exist
828 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
829 GetProperty = Null
831 Check:
832 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
833 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
834 End If
836 Try:
837 Select Case UCase(PropertyName)
838 Case Else
839 End Select
841 Finally:
842 SF_Utils._ExitFunction(cstThisSub)
843 Exit Function
844 Catch:
845 GoTo Finally
846 End Function ' ScriptForge.SF_Array.GetProperty
848 REM -----------------------------------------------------------------------------
849 Public Function ImportFromCSVFile(Optional ByRef FileName As Variant _
850 , Optional ByVal Delimiter As Variant _
851 , Optional ByVal DateFormat As Variant _
852 , Optional ByVal _IsoDate As Variant _
853 ) As Variant
854 ''' Import the data contained in a comma-separated values (CSV) file
855 ''' The comma may be replaced by any character
856 ''' Each line in the file contains a full record
857 ''' Line splitting is not allowed)
858 ''' However sequences like \n, \t, ... are left unchanged. Use SF_String.Unescape() to manage them
859 ''' A special mechanism is implemented to load dates
860 ''' The applicable CSV format is described in https://tools.ietf.org/html/rfc4180
861 ''' Args:
862 ''' FileName: the name of the text file containing the data expressed as given by the current FileNaming
863 ''' property of the SF_FileSystem service. Default = both URL format or native format
864 ''' Delimiter: Default = ",". Other usual options are ";" and the tab character
865 ''' DateFormat: either YYYY-MM-DD, DD-MM-YYYY or MM-DD-YYYY
866 ''' The dash (-) may be replaced by a dot (.), a slash (/) or a space
867 ''' Other date formats will be ignored
869 ''' _IsoDate: when True, the execution is initiated from Python, do not convert dates to Date variables. Internal use only
870 ''' Returns:
872 ''' and each column corresponding with a field of the record
873 ''' No check is made about the coherence of the field types across columns
874 ''' A best guess will be made to identify numeric and date types
875 ''' If a line contains less or more fields than the first line in the file,
876 ''' an exception will be raised. Empty lines however are simply ignored
877 ''' If the size of the file exceeds the number of items limit, a warning is raised
878 ''' and the array is truncated
879 ''' Exceptions:
880 ''' CSVPARSINGERROR Given file is not formatted as a csv file
881 ''' CSVOVERFLOWWARNING Maximum number of allowed items exceeded
883 Dim vArray As Variant ' Returned array
884 Dim lCol As Long ' Index of last column of vArray
885 Dim lRow As Long ' Index of current row of vArray
886 Dim lFileSize As Long ' Number of records found in the file
887 Dim vCsv As Object ' CSV file handler
888 Dim sLine As String ' Last read line
889 Dim vLine As Variant ' Array of fields of last read line
890 Dim sItem As String ' Individual item in the file
891 Dim vItem As Variant ' Individual item in the output array
892 Dim iPosition As Integer ' Date position in individual item
893 Dim iYear As Integer, iMonth As Integer, iDay As Integer
894 ' Date components
895 Dim i As Long
898 Const cstSubArgs = "FileName, [Delimiter="",""], [DateFormat=""""]"
900 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
901 vArray = Array()
903 Check:
905 If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat = ""
906 If IsMissing(_IsoDate) Or IsEmpty(_IsoDate) Then _IsoDate = False
907 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
911 End If
914 Try:
915 ' Counts the lines present in the file to size the final array
916 ' Very beneficial for large files, better than multiple ReDims
917 ' Small overhead for small files
918 lFileSize = SF_FileSystem._CountTextLines(FileName, False)
921 ' Reread file line by line
922 Set vCsv = SF_FileSystem.OpenTextFile(FileName, IOMode := SF_FileSystem.ForReading)
923 If IsNull(vCsv) Then GoTo Finally ' Open error
924 lRow = -1
925 With vCsv
926 Do While Not .AtEndOfStream
927 sLine = .ReadLine()
929 If InStr(sLine, """") > 0 Then vLine = SF_String.SplitNotQuoted(sLine, Delimiter) Else vLine = Split(sLine, Delimiter) ' Simple split when relevant
930 lRow = lRow + 1
932 lCol = UBound(vLine)
934 ElseIf UBound(vLine) <> lCol Then
935 GoTo CatchCSVFormat
936 End If
937 ' Check type and copy all items of the line
938 For i = 0 To lCol
939 If Left(vLine(i), 1) = """" Then sItem = SF_String.Unquote(vLine(i)) Else sItem = vLine(i) ' Unquote only when useful
940 ' Interpret the individual line item
941 Select Case True
942 Case IsNumeric(sItem)
943 If InStr(sItem, ".") + InStr(1, sItem, "e", 1) > 0 Then vItem = Val(sItem) Else vItem = CLng(sItem)
944 Case DateFormat <> "" And Len(sItem) = Len(DateFormat)
945 If SF_String.IsADate(sItem, DateFormat) Then
949 vItem = DateSerial(iYear, iMonth, iDay)
950 If _IsoDate Then vItem = SF_Utils._CDateToIso(vItem) ' Called from Python
951 Else
952 vItem = sItem
953 End If
954 Case Else : vItem = sItem
955 End Select
956 vArray(lRow, i) = vItem
957 Next i
958 End If
959 ' Provision to avoid very large arrays and their sometimes erratic behaviour
962 GoTo CatchOverflow
963 End If
964 Loop
965 End With
967 Finally:
968 If Not IsNull(vCsv) Then
969 vCsv.CloseFile()
970 Set vCsv = vCsv.Dispose()
971 End If
972 ImportFromCSVFile = vArray
973 SF_Utils._ExitFunction(cstThisSub)
974 Exit Function
975 Catch:
976 GoTo Finally
977 CatchCSVFormat:
978 SF_Exception.RaiseFatal(CSVPARSINGERROR, FileName, vCsv.Line, sLine)
979 GoTo Finally
980 CatchOverflow:
981 'TODO SF_Exception.RaiseWarning(SF_Exception.CSVOVERFLOWWARNING, cstThisSub)
983 GoTo Finally
984 End Function ' ScriptForge.SF_Array.ImportFromCSVFile
986 REM -----------------------------------------------------------------------------
987 Public Function IndexOf(Optional ByRef Array_1D As Variant _
988 , Optional ByVal ToFind As Variant _
989 , Optional ByVal CaseSensitive As Variant _
990 , Optional ByVal SortOrder As Variant _
991 ) As Long
993 ''' ToFind must exist within the array.
994 ''' The comparison between strings can be done case-sensitively or not
995 ''' If the array is sorted then
996 ''' the array must be filled homogeneously, i.e. all items must be of the same type
997 ''' Empty and Null items are forbidden
998 ''' a binary search is done
999 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
1000 ''' Args:
1001 ''' Array_1D: the array to scan
1002 ''' ToFind: a number, a date or a string to find
1003 ''' CaseSensitive: Only for string comparisons, default = False
1004 ''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
1006 ''' Result is unpredictable when array is announced sorted and is in reality not
1007 ''' Examples:
1008 ''' SF_Array.IndexOf(Array("A","B","c","D"), "C", SortOrder := "ASC") returns 2
1009 ''' SF_Array.IndexOf(Array("A","B","c","D"), "C", CaseSensitive := True) returns -1
1012 Dim lIndex As Long ' Return value
1013 Dim iToFindType As Integer ' VarType of ToFind
1015 Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
1017 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1019 lIndex = -1
1021 Check:
1022 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1023 If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
1024 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1025 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
1026 If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
1027 iToFindType = SF_Utils._VarTypeExt(ToFind)
1028 If SortOrder <> "" Then
1030 Else
1032 End If
1033 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1034 End If
1036 Try:
1037 vFindItem = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder)
1040 Finally:
1041 IndexOf = lIndex
1042 SF_Utils._ExitFunction(cstThisSub)
1043 Exit Function
1044 Catch:
1045 GoTo Finally
1046 End Function ' ScriptForge.SF_Array.IndexOf
1048 REM -----------------------------------------------------------------------------
1049 Public Function Insert(Optional ByRef Array_1D As Variant _
1050 , Optional ByVal Before As Variant _
1051 , ParamArray pvArgs() As Variant _
1052 ) As Variant
1053 ''' Insert before the index Before of the input array the items listed as arguments
1054 ''' Arguments are inserted blindly
1055 ''' each of them might be a scalar of any type or a subarray
1056 ''' Args
1057 ''' Array_1D: the pre-existing array, may be empty
1058 ''' Before: the index before which to insert; must be in the interval [LBound, UBound + 1]
1059 ''' pvArgs: a list of items to Insert inside Array_1D
1060 ''' Returns:
1061 ''' the new rxtended array. Its LBound is identical to that of Array_1D
1062 ''' Exceptions:
1063 ''' ARRAYINSERTERROR
1064 ''' Examples:
1067 Dim vInsert As Variant ' Return value
1068 Dim lNbArgs As Long ' Number of elements to Insert
1069 Dim lMin As Long ' LBound of input array
1070 Dim lMax As Long ' UBound of input array
1071 Dim i As Long
1075 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1076 vInsert = Array()
1078 Check:
1079 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1083 End If
1085 Try:
1087 lMin = LBound(Array_1D) ' = LBound(vInsert)
1088 lMax = UBound(Array_1D) ' <> UBound(vInsert)
1090 ReDim vInsert(lMin To lMax + lNbArgs)
1091 For i = lMin To UBound(vInsert)
1092 If i < Before Then
1093 vInsert(i) = Array_1D(i)
1094 ElseIf i < Before + lNbArgs Then
1095 vInsert(i) = pvArgs(i - Before)
1096 Else
1097 vInsert(i) = Array_1D(i - lNbArgs)
1098 End If
1099 Next i
1100 Else
1101 vInsert() = Array_1D()
1102 End If
1104 Finally:
1105 Insert = vInsert()
1106 SF_Utils._ExitFunction(cstThisSub)
1107 Exit Function
1108 Catch:
1109 GoTo Finally
1110 CatchArgument:
1111 'TODO SF_Exception.RaiseFatal(ARRAYINSERTERROR, cstThisSub)
1113 GoTo Finally
1114 End Function ' ScriptForge.SF_Array.Insert
1116 REM -----------------------------------------------------------------------------
1117 Public Function InsertSorted(Optional ByRef Array_1D As Variant _
1118 , Optional ByVal Item As Variant _
1119 , Optional ByVal SortOrder As Variant _
1120 , Optional ByVal CaseSensitive As Variant _
1121 ) As Variant
1122 ''' Insert in a sorted array a new item on its place
1123 ''' the array must be filled homogeneously, i.e. all items must be of the same type
1124 ''' Empty and Null items are forbidden
1125 ''' Args:
1126 ''' Array_1D: the array to sort
1127 ''' Item: the scalar value to insert, same type as the existing array items
1129 ''' CaseSensitive: Default = False
1130 ''' Returns: the extended sorted array with same LBound as input array
1131 ''' Examples:
1132 ''' InsertSorted(Array("A", "C", "a", "b"), "B", CaseSensitive := True) returns ("A", "B", "C", "a", "b")
1134 Dim vSorted() As Variant ' Return value
1135 Dim iType As Integer ' VarType of elements in input array
1136 Dim lMin As Long ' LBound of input array
1137 Dim lMax As Long ' UBound of input array
1138 Dim lIndex As Long ' Place where to insert new item
1140 Const cstSubArgs = "Array_1D, Item, [SortOrder=""ASC""|""DESC""], [CaseSensitive=False]"
1142 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1143 vSorted = Array()
1145 Check:
1147 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1148 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1150 If LBound(Array_1D) <= UBound(Array_1D) Then
1151 iType = SF_Utils._VarTypeExt(Array_1D(LBound(Array_1D)))
1153 Else
1154 If Not SF_Utils._Validate(Item, "Item", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
1155 End If
1156 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1157 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1158 End If
1160 Try:
1161 lMin = LBound(Array_1D)
1162 lMax = UBound(Array_1D)
1163 lIndex = SF_Array._FindItem(Array_1D, Item, CaseSensitive, SortOrder)(1)
1164 vSorted = SF_Array.Insert(Array_1D, lIndex, Item)
1166 Finally:
1167 InsertSorted = vSorted()
1168 SF_Utils._ExitFunction(cstThisSub)
1169 Exit Function
1170 Catch:
1171 GoTo Finally
1172 End Function ' ScriptForge.SF_Array.InsertSorted
1174 REM -----------------------------------------------------------------------------
1175 Public Function Intersection(Optional ByRef Array1_1D As Variant _
1176 , Optional ByRef Array2_1D As Variant _
1177 , Optional ByVal CaseSensitive As Variant _
1178 ) As Variant
1179 ''' Build a set being the intersection of the two input arrays, i.e. items are contained in both arrays
1180 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
1181 ''' Empty and Null items are forbidden
1182 ''' The comparison between strings is case sensitive or not
1183 ''' Args:
1186 ''' CaseSensitive: default = False
1187 ''' Returns: a zero-based array containing unique items stored in both input arrays
1188 ''' The output array is sorted in ascending order
1189 ''' Examples:
1190 ''' Intersection(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("C", "b")
1192 Dim vIntersection() As Variant ' Return value
1193 Dim vSorted() As Variant ' The shortest input array after sort
1194 Dim iType As Integer ' VarType of elements in input arrays
1199 Dim lMin As Long ' LBound of unsorted array
1200 Dim lMax As Long ' UBound of unsorted array
1202 Dim lSize As Long ' Number of Intersection items
1203 Dim vItem As Variant ' One single item in the array
1204 Dim i As Long
1208 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1209 vIntersection = Array()
1211 Check:
1212 If IsMissing(CaseSensitive) Then CaseSensitive = False
1213 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1215 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
1216 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
1217 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1218 End If
1220 Try:
1221 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
1222 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
1224 ' If one of both arrays is empty, do nothing
1227 ' First sort the shortest array
1228 If lMax1 - lMin1 <= lMax2 - lMin2 Then
1229 iShortest = 1
1231 lMin = lMin2 : lMax = lMax2 ' Bounds of unsorted array
1232 Else
1233 iShortest = 2
1235 lMin = lMin1 : lMax = lMax1 ' Bounds of unsorted array
1236 End If
1238 ' Resize the output array to the size of the shortest array
1239 ReDim vIntersection(0 To (lMax - lMin))
1240 lSize = -1
1242 ' Fill vIntersection one by one only with items present in both sets
1243 For i = lMin To lMax
1244 If iShortest = 1 Then vItem = Array2_1D(i) Else vItem = Array1_1D(i) ' Pick in unsorted array
1246 lSize = lSize + 1
1247 vIntersection(lSize) = vItem
1248 End If
1249 Next i
1251 ' Remove unfilled entries and duplicates
1253 ReDim Preserve vIntersection(0 To lSize)
1254 vIntersection() = SF_Array.Unique(vIntersection, CaseSensitive)
1255 Else
1256 vIntersection = Array()
1257 End If
1258 End If
1260 Finally:
1261 Intersection = vIntersection()
1262 SF_Utils._ExitFunction(cstThisSub)
1263 Exit Function
1264 Catch:
1265 GoTo Finally
1266 End Function ' ScriptForge.SF_Array.Intersection
1268 REM -----------------------------------------------------------------------------
1269 Public Function Join2D(Optional ByRef Array_2D As Variant _
1270 , Optional ByVal ColumnDelimiter As Variant _
1271 , Optional ByVal RowDelimiter As Variant _
1272 , Optional ByVal Quote As Variant _
1273 ) As String
1274 ''' Join a two-dimensional array with two delimiters, one for columns, one for rows
1275 ''' Args:
1276 ''' Array_2D: each item must be either a String, a number, a Date or a Boolean
1279 ''' Quote: if True, protect strings with double quotes (default = False)
1280 ''' Return:
1281 ''' A string after conversion of numbers and dates
1282 ''' Invalid items are replaced by a zero-length string
1283 ''' Examples:
1285 ''' SF_Array.Join_2D( | 6, 7, "this is a string", 9, 10 | , ",", "/")
1288 Dim sJoin As String ' The return value
1289 Dim sItem As String ' The string representation of a single item
1290 Dim vItem As Variant ' Single item
1291 Dim lMin1 As Long ' LBound1 of input array
1292 Dim lMax1 As Long ' UBound1 of input array
1293 Dim lMin2 As Long ' LBound2 of input array
1294 Dim lMax2 As Long ' UBound2 of input array
1295 Dim i As Long
1296 Dim j As Long
1298 Const cstSubArgs = "Array_2D, [ColumnDelimiter=Chr(9)], [RowDelimiter=Chr(10)], [Quote=False]"
1300 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1301 sJoin = ""
1303 Check:
1304 If IsMissing(ColumnDelimiter) Or IsEmpty(ColumnDelimiter) Then ColumnDelimiter = Chr(9)
1305 If IsMissing(RowDelimiter) Or IsEmpty(RowDelimiter) Then RowDelimiter = Chr(10)
1306 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1308 If Not SF_Utils._Validate(ColumnDelimiter, "ColumnDelimiter", V_STRING) Then GoTo Finally
1311 End If
1313 Try:
1316 If lMin1 <= lMax1 Then
1317 For i = lMin1 To lMax1
1318 For j = lMin2 To lMax2
1319 vItem = Array_2D(i, j)
1320 Select Case SF_Utils._VarTypeExt(vItem)
1321 Case V_STRING : If Quote Then sItem = SF_String.Quote(vItem) Else sItem = vItem
1322 Case V_NUMERIC, V_DATE : sItem = SF_Utils._Repr(vItem)
1324 Case Else : sItem = ""
1325 End Select
1327 Next j
1329 Next i
1330 End If
1332 Finally:
1333 Join2D = sJoin
1334 SF_Utils._ExitFunction(cstThisSub)
1335 Exit Function
1336 Catch:
1337 GoTo Finally
1338 End Function ' ScriptForge.SF_Array.Join2D
1340 REM -----------------------------------------------------------------------------
1341 Public Function Methods() As Variant
1342 ''' Return the list of public methods of the Array service as an array
1344 Methods = Array( _
1375 )
1377 End Function ' ScriptForge.SF_Array.Methods
1379 REM -----------------------------------------------------------------------------
1380 Public Function Prepend(Optional ByRef Array_1D As Variant _
1381 , ParamArray pvArgs() As Variant _
1382 ) As Variant
1383 ''' Prepend at the beginning of the input array the items listed as arguments
1384 ''' Arguments are Prepended blindly
1385 ''' each of them might be a scalar of any type or a subarray
1386 ''' Args
1387 ''' Array_1D: the pre-existing array, may be empty
1388 ''' pvArgs: a list of items to Prepend to Array_1D
1389 ''' Return: the new rxtended array. Its LBound is identical to that of Array_1D
1390 ''' Examples:
1393 Dim vPrepend As Variant ' Return value
1394 Dim lNbArgs As Long ' Number of elements to Prepend
1395 Dim lMin As Long ' LBound of input array
1396 Dim lMax As Long ' UBound of input array
1397 Dim i As Long
1401 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1402 vPrepend = Array()
1404 Check:
1405 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1407 End If
1409 Try:
1411 lMin = LBound(Array_1D) ' = LBound(vPrepend)
1412 lMax = UBound(Array_1D) ' <> UBound(vPrepend)
1415 Else
1416 ReDim vPrepend(lMin To lMax + lNbArgs)
1417 End If
1418 For i = lMin To UBound(vPrepend)
1419 If i < lMin + lNbArgs Then vPrepend(i) = pvArgs(i - lMin) Else vPrepend(i) = Array_1D(i - lNbArgs)
1420 Next i
1422 Finally:
1423 Prepend = vPrepend
1424 SF_Utils._ExitFunction(cstThisSub)
1425 Exit Function
1426 Catch:
1427 GoTo Finally
1428 End Function ' ScriptForge.SF_Array.Prepend
1430 REM -----------------------------------------------------------------------------
1431 Public Function PrependColumn(Optional ByRef Array_2D As Variant _
1432 , Optional ByRef Column As Variant _
1433 ) As Variant
1435 ''' Args
1436 ''' Array_2D: the pre-existing array, may be empty
1437 ''' If the array has 1 dimension, it is considered as the last Column of the resulting 2D array
1439 ''' Returns:
1440 ''' the new rxtended array. Its LBounds are identical to that of Array_2D
1441 ''' Exceptions:
1442 ''' ARRAYINSERTERROR
1443 ''' Examples:
1444 ''' SF_Array.PrependColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 1), (5, 2), (6, 3))
1445 ''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
1447 Dim vPrependColumn As Variant ' Return value
1448 Dim iDims As Integer ' Dimensions of Array_2D
1449 Dim lMin1 As Long ' LBound1 of input array
1450 Dim lMax1 As Long ' UBound1 of input array
1451 Dim lMin2 As Long ' LBound2 of input array
1452 Dim lMax2 As Long ' UBound2 of input array
1453 Dim lMin As Long ' LBound of Column array
1454 Dim lMax As Long ' UBound of Column array
1455 Dim i As Long
1456 Dim j As Long
1460 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1461 vPrependColumn = Array()
1463 Check:
1464 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1465 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
1467 End If
1468 iDims = SF_Array.CountDims(Array_2D)
1470 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
1471 End If
1473 Try:
1474 lMin = LBound(Column)
1475 lMax = UBound(Column)
1477 ' Compute future dimensions of output array
1478 Select Case iDims
1479 Case 0 : lMin1 = lMin : lMax1 = lMax
1485 End Select
1487 ReDim vPrependColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
1489 ' Copy input array to output array
1490 For i = lMin1 To lMax1
1492 If iDims = 2 Then vPrependColumn(i, j) = Array_2D(i, j - 1) Else vPrependColumn(i, j) = Array_2D(i)
1493 Next j
1494 Next i
1495 ' Copy new Column
1496 For i = lMin1 To lMax1
1497 vPrependColumn(i, lMin2) = Column(i)
1498 Next i
1500 Finally:
1501 PrependColumn = vPrependColumn()
1502 SF_Utils._ExitFunction(cstThisSub)
1503 Exit Function
1504 Catch:
1505 GoTo Finally
1506 CatchColumn:
1507 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
1508 GoTo Finally
1509 End Function ' ScriptForge.SF_Array.PrependColumn
1511 REM -----------------------------------------------------------------------------
1512 Public Function PrependRow(Optional ByRef Array_2D As Variant _
1513 , Optional ByRef Row As Variant _
1514 ) As Variant
1516 ''' Args
1517 ''' Array_2D: the pre-existing array, may be empty
1518 ''' If the array has 1 dimension, it is considered as the last row of the resulting 2D array
1520 ''' Returns:
1521 ''' the new rxtended array. Its LBounds are identical to that of Array_2D
1522 ''' Exceptions:
1523 ''' ARRAYINSERTERROR
1524 ''' Examples:
1525 ''' SF_Array.PrependRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 5, 6), (1, 2, 3))
1526 ''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
1528 Dim vPrependRow As Variant ' Return value
1529 Dim iDims As Integer ' Dimensions of Array_2D
1530 Dim lMin1 As Long ' LBound1 of input array
1531 Dim lMax1 As Long ' UBound1 of input array
1532 Dim lMin2 As Long ' LBound2 of input array
1533 Dim lMax2 As Long ' UBound2 of input array
1534 Dim lMin As Long ' LBound of row array
1535 Dim lMax As Long ' UBound of row array
1536 Dim i As Long
1537 Dim j As Long
1541 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1542 vPrependRow = Array()
1544 Check:
1545 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1546 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
1548 End If
1549 iDims = SF_Array.CountDims(Array_2D)
1551 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
1552 End If
1554 Try:
1555 lMin = LBound(Row)
1556 lMax = UBound(Row)
1558 ' Compute future dimensions of output array
1559 Select Case iDims
1561 lMin2 = lMin : lMax2 = lMax
1566 End Select
1568 ReDim vPrependRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
1570 ' Copy input array to output array
1572 For j = lMin2 To lMax2
1574 Next j
1575 Next i
1576 ' Copy new row
1577 For j = lMin2 To lMax2
1578 vPrependRow(lMin1, j) = Row(j)
1579 Next j
1581 Finally:
1582 PrependRow = vPrependRow()
1583 SF_Utils._ExitFunction(cstThisSub)
1584 Exit Function
1585 Catch:
1586 GoTo Finally
1587 CatchRow:
1588 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
1589 GoTo Finally
1590 End Function ' ScriptForge.SF_Array.PrependRow
1592 REM -----------------------------------------------------------------------------
1593 Public Function Properties() As Variant
1594 ''' Return the list or properties as an array
1596 Properties = Array( _
1597 )
1599 End Function ' ScriptForge.SF_Array.Properties
1601 REM -----------------------------------------------------------------------------
1602 Public Function RangeInit(Optional ByVal From As Variant _
1603 , Optional ByVal UpTo As Variant _
1604 , Optional ByVal ByStep As Variant _
1605 ) As Variant
1606 ''' Initialize a new zero-based array with numeric values
1607 ''' Args: all numeric
1608 ''' From: value of first item
1609 ''' UpTo: last item should not exceed UpTo
1611 ''' Return: the new array
1612 ''' Exceptions:
1614 ''' Examples:
1617 Dim lIndex As Long ' Index of array
1618 Dim lSize As Long ' UBound of resulting array
1619 Dim vCurrentItem As Variant ' Last stored item
1620 Dim vArray() ' The return value
1624 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1625 vArray = Array()
1627 Check:
1628 If IsMissing(ByStep) Or IsEmpty(ByStep) Then ByStep = 1
1629 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1633 End If
1634 If (From < UpTo And ByStep <= 0) Or (From > UpTo And ByStep >= 0) Then GoTo CatchSequence
1636 Try:
1637 lSize = CLng(Abs((UpTo - From) / ByStep))
1638 ReDim vArray(0 To lSize)
1639 For lIndex = 0 To lSize
1640 vArray(lIndex) = From + lIndex * ByStep
1641 Next lIndex
1643 Finally:
1644 RangeInit = vArray
1645 SF_Utils._ExitFunction(cstThisSub)
1646 Exit Function
1647 Catch:
1648 GoTo Finally
1649 CatchSequence:
1650 SF_Exception.RaiseFatal(ARRAYSEQUENCEERROR, From, UpTo, ByStep)
1651 GoTo Finally
1652 End Function ' ScriptForge.SF_Array.RangeInit
1654 REM -----------------------------------------------------------------------------
1655 Public Function Reverse(Optional ByRef Array_1D As Variant) As Variant
1657 ''' Args:
1658 ''' Array_1D: the array to reverse
1659 ''' Returns: the reversed array
1660 ''' Examples:
1663 Dim vReverse() As Variant ' Return value
1664 Dim lHalf As Long ' Middle of array
1665 Dim lMin As Long ' LBound of input array
1666 Dim lMax As Long ' UBound of input array
1667 Dim i As Long, j As Long
1671 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1672 vReverse = Array()
1674 Check:
1675 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1677 End If
1679 Try:
1680 lMin = LBound(Array_1D)
1681 lMax = UBound(Array_1D)
1682 ReDim vReverse(lMin To lMax)
1683 lHalf = Int((lMax + lMin) / 2)
1684 j = lMax
1685 For i = lMin To lHalf
1686 vReverse(i) = Array_1D(j)
1687 vReverse(j) = Array_1D(i)
1688 j = j - 1
1689 Next i
1690 ' Odd number of items
1693 Finally:
1694 Reverse = vReverse()
1695 SF_Utils._ExitFunction(cstThisSub)
1696 Exit Function
1697 Catch:
1698 GoTo Finally
1699 End Function ' ScriptForge.SF_Array.Reverse
1701 REM -----------------------------------------------------------------------------
1702 Public Function SetProperty(Optional ByVal PropertyName As Variant _
1703 , Optional ByRef Value As Variant _
1704 ) As Boolean
1705 ''' Set a new value to the given property
1706 ''' Args:
1707 ''' PropertyName: the name of the property as a string
1708 ''' Value: its new value
1709 ''' Exceptions
1710 ''' ARGUMENTERROR The property does not exist
1715 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1716 SetProperty = False
1718 Check:
1719 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1720 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
1721 End If
1723 Try:
1724 Select Case UCase(PropertyName)
1725 Case Else
1726 End Select
1728 Finally:
1729 SF_Utils._ExitFunction(cstThisSub)
1730 Exit Function
1731 Catch:
1732 GoTo Finally
1733 End Function ' ScriptForge.SF_Array.SetProperty
1735 REM -----------------------------------------------------------------------------
1736 Public Function Shuffle(Optional ByRef Array_1D As Variant) As Variant
1739 ''' Args:
1740 ''' Array_1D: the array to shuffle
1741 ''' Returns: the shuffled array
1743 Dim vShuffle() As Variant ' Return value
1744 Dim vSwapValue As Variant ' Intermediate value during swap
1745 Dim lMin As Long ' LBound of Array_1D
1746 Dim lCurrentIndex As Long ' Decremented from UBount to LBound
1747 Dim lRandomIndex As Long ' Random between LBound and lCurrentIndex
1748 Dim i As Long
1752 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1753 vShuffle = Array()
1755 Check:
1756 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1758 End If
1760 Try:
1761 lMin = LBound(Array_1D)
1762 lCurrentIndex = UBound(array_1D)
1763 ' Initialize the output array
1764 ReDim vShuffle(lMin To lCurrentIndex)
1765 For i = lMin To lCurrentIndex
1766 vShuffle(i) = Array_1D(i)
1767 Next i
1768 ' Now ... shuffle !
1769 Do While lCurrentIndex > lMin
1770 lRandomIndex = Int(Rnd * (lCurrentIndex - lMin)) + lMin
1771 vSwapValue = vShuffle(lCurrentIndex)
1772 vShuffle(lCurrentIndex) = vShuffle(lRandomIndex)
1773 vShuffle(lRandomIndex) = vSwapValue
1774 lCurrentIndex = lCurrentIndex - 1
1775 Loop
1777 Finally:
1778 Shuffle = vShuffle()
1779 SF_Utils._ExitFunction(cstThisSub)
1780 Exit Function
1781 Catch:
1782 GoTo Finally
1783 End Function ' ScriptForge.SF_Array.Shuffle
1785 REM -----------------------------------------------------------------------------
1786 Public Function Slice(Optional ByRef Array_1D As Variant _
1787 , Optional ByVal From As Variant _
1788 , Optional ByVal UpTo As Variant _
1789 ) As Variant
1791 ''' Args:
1792 ''' Array_1D: the array to slice
1793 ''' From: the lower index of the subarray to extract (included)
1794 ''' UpTo: the upper index of the subarray to extract (included). Default = the last item of Array_1D
1795 ''' Returns:
1796 ''' The selected subarray with the same LBound as the input array.
1798 ''' Exceptions:
1799 ''' ARRAYINDEX2ERROR Wrong values for From and/or UpTo
1800 ''' Example:
1803 Dim vSlice() As Variant ' Return value
1804 Dim lMin As Long ' LBound of Array_1D
1805 Dim lIndex As Long ' Current index in output array
1806 Dim i As Long
1810 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1811 vSlice = Array()
1813 Check:
1814 If IsMissing(UpTo) Or IsEmpty(UpTo) Then UpTo = -1
1815 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1819 End If
1820 If UpTo = -1 Then UpTo = UBound(Array_1D)
1824 Try:
1825 If UpTo >= From Then
1826 lMin = LBound(Array_1D)
1827 ' Initialize the output array
1828 ReDim vSlice(lMin To lMin + UpTo - From)
1829 lIndex = lMin - 1
1830 For i = From To UpTo
1831 lIndex = lIndex + 1
1832 vSlice(lIndex) = Array_1D(i)
1833 Next i
1834 End If
1836 Finally:
1837 Slice = vSlice()
1838 SF_Utils._ExitFunction(cstThisSub)
1839 Exit Function
1840 Catch:
1841 GoTo Finally
1842 CatchIndex:
1843 SF_Exception.RaiseFatal(ARRAYINDEX2ERROR, SF_Array._Repr(Array_1D), From, UpTo)
1844 GoTo Finally
1845 End Function ' ScriptForge.SF_Array.Slice
1847 REM -----------------------------------------------------------------------------
1848 Public Function Sort(Optional ByRef Array_1D As Variant _
1849 , Optional ByVal SortOrder As Variant _
1850 , Optional ByVal CaseSensitive As Variant _
1851 ) As Variant
1852 ''' Sort a 1D array in ascending or descending order. String comparisons can be case-sensitive or not
1853 ''' Args:
1854 ''' Array_1D: the array to sort
1855 ''' must be filled homogeneously by either strings, dates or numbers
1856 ''' Null and Empty values are allowed
1858 ''' CaseSensitive: Default = False
1859 ''' Returns: the sorted array
1860 ''' Examples:
1861 ''' Sort(Array("a", "A", "b", "B", "C"), CaseSensitive := True) returns ("A", "B", "C", "a", "b")
1863 Dim vSort() As Variant ' Return value
1864 Dim vIndexes() As Variant ' Indexes of sorted items
1865 Dim lMin As Long ' LBound of input array
1866 Dim lMax As Long ' UBound of input array
1867 Dim i As Long
1869 Const cstSubArgs = "Array_1D, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
1871 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1872 vSort = Array()
1874 Check:
1876 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1877 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1879 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1880 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1881 End If
1883 Try:
1884 lMin = LBound(Array_1D)
1885 lMax = UBound(Array_1D)
1888 ' Load output array
1889 ReDim vSort(lMin To lMax)
1890 For i = lMin To lMax
1891 vSort(i) = Array_1D(vIndexes(i))
1892 Next i
1894 Finally:
1895 Sort = vSort()
1896 SF_Utils._ExitFunction(cstThisSub)
1897 Exit Function
1898 Catch:
1899 GoTo Finally
1900 End Function ' ScriptForge.SF_Array.Sort
1902 REM -----------------------------------------------------------------------------
1903 Public Function SortColumns(Optional ByRef Array_2D As Variant _
1904 , Optional ByVal RowIndex As Variant _
1905 , Optional ByVal SortOrder As Variant _
1906 , Optional ByVal CaseSensitive As Variant _
1907 ) As Variant
1908 ''' Returns a permutation of the columns of a 2D array, sorted on the values of a given row
1909 ''' Args:
1910 ''' Array_2D: the input array
1911 ''' RowIndex: the index of the row to sort the columns on
1912 ''' the row must be filled homogeneously by either strings, dates or numbers
1913 ''' Null and Empty values are allowed
1915 ''' CaseSensitive: Default = False
1916 ''' Returns:
1917 ''' the array with permuted columns, LBounds and UBounds are unchanged
1918 ''' Exceptions:
1919 ''' ARRAYINDEXERROR
1920 ''' Examples:
1925 Dim vSort() As Variant ' Return value
1926 Dim vRow() As Variant ' The row on which to sort the array
1927 Dim vIndexes() As Variant ' Indexes of sorted row
1928 Dim lMin1 As Long ' LBound1 of input array
1929 Dim lMax1 As Long ' UBound1 of input array
1930 Dim lMin2 As Long ' LBound2 of input array
1931 Dim lMax2 As Long ' UBound2 of input array
1932 Dim i As Long, j As Long
1934 Const cstSubArgs = "Array_2D, RowIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
1936 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1937 vSort = Array()
1939 Check:
1941 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1942 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1945 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1946 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1947 End If
1949 Try:
1954 ' Extract and sort the RowIndex-th row
1955 vRow = SF_Array.ExtractRow(Array_2D, RowIndex)
1956 If Not SF_Utils._ValidateArray(vRow, "Row #" & CStr(RowIndex), 1, 0) Then GoTo Finally
1959 ' Load output array
1960 ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
1961 For i = lMin1 To lMax1
1962 For j = lMin2 To lMax2
1963 vSort(i, j) = Array_2D(i, vIndexes(j))
1964 Next j
1965 Next i
1967 Finally:
1968 SortColumns = vSort()
1969 SF_Utils._ExitFunction(cstThisSub)
1970 Exit Function
1971 Catch:
1972 GoTo Finally
1973 CatchIndex:
1974 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
1976 GoTo Finally
1977 End Function ' ScriptForge.SF_Array.SortColumns
1979 REM -----------------------------------------------------------------------------
1980 Public Function SortRows(Optional ByRef Array_2D As Variant _
1981 , Optional ByVal ColumnIndex As Variant _
1982 , Optional ByVal SortOrder As Variant _
1983 , Optional ByVal CaseSensitive As Variant _
1984 ) As Variant
1985 ''' Returns a permutation of the rows of a 2D array, sorted on the values of a given column
1986 ''' Args:
1987 ''' Array_2D: the input array
1988 ''' ColumnIndex: the index of the column to sort the rows on
1989 ''' the column must be filled homogeneously by either strings, dates or numbers
1990 ''' Null and Empty values are allowed
1992 ''' CaseSensitive: Default = False
1993 ''' Returns:
1994 ''' the array with permuted Rows, LBounds and UBounds are unchanged
1995 ''' Exceptions:
1996 ''' ARRAYINDEXERROR
1997 ''' Examples:
2002 Dim vSort() As Variant ' Return value
2003 Dim vCol() As Variant ' The column on which to sort the array
2004 Dim vIndexes() As Variant ' Indexes of sorted row
2005 Dim lMin1 As Long ' LBound1 of input array
2006 Dim lMax1 As Long ' UBound1 of input array
2007 Dim lMin2 As Long ' LBound2 of input array
2008 Dim lMax2 As Long ' UBound2 of input array
2009 Dim i As Long, j As Long
2011 Const cstSubArgs = "Array_2D, ColumnIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
2013 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2014 vSort = Array()
2016 Check:
2018 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
2019 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2022 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
2023 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
2024 End If
2026 Try:
2031 ' Extract and sort the ColumnIndex-th column
2032 vCol = SF_Array.ExtractColumn(Array_2D, ColumnIndex)
2033 If Not SF_Utils._ValidateArray(vCol, "Column #" & CStr(ColumnIndex), 1, 0) Then GoTo Finally
2036 ' Load output array
2037 ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
2038 For i = lMin1 To lMax1
2039 For j = lMin2 To lMax2
2040 vSort(i, j) = Array_2D(vIndexes(i), j)
2041 Next j
2042 Next i
2044 Finally:
2045 SortRows = vSort()
2046 SF_Utils._ExitFunction(cstThisSub)
2047 Exit Function
2048 Catch:
2049 GoTo Finally
2050 CatchIndex:
2051 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
2053 GoTo Finally
2054 End Function ' ScriptForge.SF_Array.SortRows
2056 REM -----------------------------------------------------------------------------
2057 Public Function Transpose(Optional ByRef Array_2D As Variant) As Variant
2059 ''' Args:
2060 ''' Array_2D: the array to transpose
2061 ''' Returns:
2062 ''' The transposed array
2063 ''' Examples:
2068 Dim vTranspose As Variant ' Return value
2069 Dim lIndex As Long ' vTranspose index
2070 Dim lMin1 As Long ' LBound1 of input array
2071 Dim lMax1 As Long ' UBound1 of input array
2072 Dim lMin2 As Long ' LBound2 of input array
2073 Dim lMax2 As Long ' UBound2 of input array
2074 Dim i As Long, j As Long
2078 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2079 vTranspose = Array()
2081 Check:
2082 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2084 End If
2086 Try:
2087 ' Resize the output array
2090 If lMin1 <= lMax1 Then
2091 ReDim vTranspose(lMin2 To lMax2, lMin1 To lMax1)
2092 End If
2094 ' Transpose items
2095 For i = lMin1 To lMax1
2096 For j = lMin2 To lMax2
2097 vTranspose(j, i) = Array_2D(i, j)
2098 Next j
2099 Next i
2101 Finally:
2102 Transpose = vTranspose
2103 SF_Utils._ExitFunction(cstThisSub)
2104 Exit Function
2105 Catch:
2106 GoTo Finally
2107 End Function ' ScriptForge.SF_Array.Transpose
2109 REM -----------------------------------------------------------------------------
2110 Public Function TrimArray(Optional ByRef Array_1D As Variant) As Variant
2112 ''' Strings are trimmed as well
2113 ''' Args:
2114 ''' Array_1D: the array to scan
2115 ''' Return: The trimmed array
2116 ''' Examples:
2117 ''' SF_Array.TrimArray(Array("A","B",Null," D ")) returns ("A","B","D")
2119 Dim vTrimArray As Variant ' Return value
2120 Dim lIndex As Long ' vTrimArray index
2121 Dim lMin As Long ' LBound of input array
2122 Dim lMax As Long ' UBound of input array
2123 Dim vItem As Variant ' Single array item
2124 Dim i As Long
2128 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2129 vTrimArray = Array()
2131 Check:
2132 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2134 End If
2136 Try:
2137 lMin = LBound(Array_1D)
2138 lMax = UBound(Array_1D)
2139 If lMin <= lMax Then
2140 ReDim vTrimArray(lMin To lMax)
2141 End If
2142 lIndex = lMin - 1
2144 ' Load only valid items from Array_1D to vTrimArray
2145 For i = lMin To lMax
2146 vItem = Array_1D(i)
2147 Select Case VarType(vItem)
2148 Case V_EMPTY
2149 Case V_NULL : vItem = Empty
2150 Case V_STRING
2151 vItem = Trim(vItem)
2152 If Len(vItem) = 0 Then vItem = Empty
2153 Case Else
2154 End Select
2155 If Not IsEmpty(vItem) Then
2156 lIndex = lIndex + 1
2157 vTrimArray(lIndex) = vItem
2158 End If
2159 Next i
2161 'Keep valid entries
2162 If lMin <= lIndex Then
2163 ReDim Preserve vTrimArray(lMin To lIndex)
2164 Else
2165 vTrimArray = Array()
2166 End If
2168 Finally:
2169 TrimArray = vTrimArray
2170 SF_Utils._ExitFunction(cstThisSub)
2171 Exit Function
2172 Catch:
2173 GoTo Finally
2174 End Function ' ScriptForge.SF_Array.TrimArray
2176 REM -----------------------------------------------------------------------------
2177 Public Function Union(Optional ByRef Array1_1D As Variant _
2178 , Optional ByRef Array2_1D As Variant _
2179 , Optional ByVal CaseSensitive As Variant _
2180 ) As Variant
2181 ''' Build a set being the Union of the two input arrays, i.e. items are contained in any of both arrays
2182 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
2183 ''' Empty and Null items are forbidden
2184 ''' The comparison between strings is case sensitive or not
2185 ''' Args:
2188 ''' CaseSensitive: default = False
2189 ''' Returns: a zero-based array containing unique items stored in any of both input arrays
2190 ''' The output array is sorted in ascending order
2191 ''' Examples:
2192 ''' SF_Array.Union(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B", "C", "Z", "b")
2194 Dim vUnion() As Variant ' Return value
2195 Dim iType As Integer ' VarType of elements in input arrays
2200 Dim lSize As Long ' Number of Union items
2201 Dim i As Long
2205 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2206 vUnion = Array()
2208 Check:
2209 If IsMissing(CaseSensitive) Then CaseSensitive = False
2210 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2212 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
2213 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
2214 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
2215 End If
2217 Try:
2218 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
2219 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
2221 ' If both arrays are empty, do nothing
2224 vUnion = SF_Array.Unique(Array2_1D, CaseSensitive)
2226 vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
2227 Else
2229 ' Build union of both arrays
2231 lSize = -1
2233 ' Fill vUnion one by one only with items present in any set
2234 For i = lMin1 To lMax1
2235 lSize = lSize + 1
2236 vUnion(lSize) = Array1_1D(i)
2237 Next i
2238 For i = lMin2 To lMax2
2239 lSize = lSize + 1
2240 vUnion(lSize) = Array2_1D(i)
2241 Next i
2243 ' Remove duplicates
2244 vUnion() = SF_Array.Unique(vUnion, CaseSensitive)
2245 End If
2247 Finally:
2248 Union = vUnion()
2249 SF_Utils._ExitFunction(cstThisSub)
2250 Exit Function
2251 Catch:
2252 GoTo Finally
2253 End Function ' ScriptForge.SF_Array.Union
2255 REM -----------------------------------------------------------------------------
2256 Public Function Unique(Optional ByRef Array_1D As Variant _
2257 , Optional ByVal CaseSensitive As Variant _
2258 ) As Variant
2259 ''' Build a set of unique values derived from the input array
2260 ''' the input array must be filled homogeneously, i.e. all items must be of the same type
2261 ''' Empty and Null items are forbidden
2262 ''' The comparison between strings is case sensitive or not
2263 ''' Args:
2264 ''' Array_1D: the input array with potential duplicates
2265 ''' CaseSensitive: default = False
2266 ''' Returns: the array without duplicates with same LBound as input array
2267 ''' The output array is sorted in ascending order
2268 ''' Examples:
2269 ''' Unique(Array("A", "C", "A", "b", "B"), True) returns ("A", "B", "C", "b")
2271 Dim vUnique() As Variant ' Return value
2272 Dim vSorted() As Variant ' The input array after sort
2273 Dim lMin As Long ' LBound of input array
2274 Dim lMax As Long ' UBound of input array
2275 Dim lUnique As Long ' Number of unique items
2276 Dim vIndex As Variant ' Output of _FindItem() method
2277 Dim vItem As Variant ' One single item in the array
2278 Dim i As Long
2282 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2283 vUnique = Array()
2285 Check:
2286 If IsMissing(CaseSensitive) Then CaseSensitive = False
2287 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2289 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
2290 End If
2292 Try:
2293 lMin = LBound(Array_1D)
2294 lMax = UBound(Array_1D)
2295 If lMax >= lMin Then
2296 ' First sort the array
2298 ReDim vUnique(lMin To lMax)
2299 lUnique = lMin
2300 ' Fill vUnique one by one ignoring duplicates
2301 For i = lMin To lMax
2302 vItem = vSorted(i)
2303 If i = lMin Then
2304 vUnique(i) = vItem
2305 Else
2307 Else
2308 lUnique = lUnique + 1
2309 vUnique(lUnique) = vItem
2310 End If
2311 End If
2312 Next i
2313 ' Remove unfilled entries
2314 ReDim Preserve vUnique(lMin To lUnique)
2315 End If
2317 Finally:
2318 Unique = vUnique()
2319 SF_Utils._ExitFunction(cstThisSub)
2320 Exit Function
2321 Catch:
2322 GoTo Finally
2323 End Function ' ScriptForge.SF_Array.Unique
2325 REM ============================================================= PRIVATE METHODS
2327 REM -----------------------------------------------------------------------------
2328 Public Function _FindItem(ByRef pvArray_1D As Variant _
2329 , ByVal pvToFind As Variant _
2330 , ByVal pbCaseSensitive As Boolean _
2331 , ByVal psSortOrder As String _
2332 ) As Variant
2333 ''' Check if a 1D array contains the ToFind number, string or date and return its index
2334 ''' The comparison between strings can be done case-sensitively or not
2335 ''' If the array is sorted then a binary search is done
2336 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
2337 ''' Args:
2338 ''' pvArray_1D: the array to scan
2339 ''' pvToFind: a number, a date or a string to find
2340 ''' pbCaseSensitive: Only for string comparisons, default = False
2341 ''' psSortOrder: "ASC", "DESC" or "" (= not sorted, default)
2345 ''' if not found: if sorted, index of next item in the array (might be = UBound + 1)
2346 ''' if not sorted, meaningless
2347 ''' Result is unpredictable when array is announced sorted and is in reality not
2348 ''' Called by Contains, IndexOf and InsertSorted. Also called by SF_Dictionary
2350 Dim bContains As Boolean ' True if match found
2351 Dim iToFindType As Integer ' VarType of pvToFind
2352 Dim lTop As Long, lBottom As Long ' Interval in scope of binary search
2353 Dim lIndex As Long ' Index used in search
2354 Dim iCompare As Integer ' Output of _ValCompare function
2355 Dim lLoops As Long ' Count binary searches
2356 Dim lMaxLoops As Long ' Max number of loops during binary search: to avoid infinite loops if array not sorted
2359 bContains = False
2362 Else
2363 ' Search sequentially
2364 If Len(psSortOrder) = 0 Then
2365 For lIndex = LBound(pvArray_1D) To UBound(pvArray_1D)
2366 bContains = ( SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive) = 0 )
2367 If bContains Then Exit For
2368 Next lIndex
2369 Else
2370 ' Binary search
2372 lTop = UBound(pvArray_1D)
2373 lBottom = lBound(pvArray_1D)
2374 Else
2375 lBottom = UBound(pvArray_1D)
2376 lTop = lBound(pvArray_1D)
2377 End If
2378 lLoops = 0
2380 Do
2381 lLoops = lLoops + 1
2382 lIndex = (lTop + lBottom) / 2
2383 iCompare = SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive)
2384 Select Case True
2385 Case iCompare = 0 : bContains = True
2387 lTop = lIndex - 1
2389 lBottom = lIndex - 1
2391 lBottom = lIndex + 1
2393 lTop = lIndex + 1
2394 End Select
2395 Loop Until ( bContains ) Or ( lBottom > lTop And psSortOrder = "ASC" ) Or (lBottom < lTop And psSortOrder = "DESC" ) Or lLoops > lMaxLoops
2396 ' Flag first next non-matching element
2398 End If
2399 End If
2401 ' Build output array
2402 vFound(0) = bContains
2403 vFound(1) = lIndex
2404 _FindItem = vFound
2406 End Function ' ScriptForge.SF_Array._FindItem
2408 REM -----------------------------------------------------------------------------
2409 Private Function _HeapSort(ByRef pvArray As Variant _
2410 , Optional ByVal pbAscending As Boolean _
2411 , Optional ByVal pbCaseSensitive As Boolean _
2412 ) As Variant
2413 ''' Sort an array: items are presumed all strings, all dates or all numeric
2414 ''' Null or Empty are allowed and are considered smaller than other items
2415 ''' https://en.wikipedia.org/wiki/Heapsort
2416 ''' http://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-(sort-array-sorting-arrays)&p=2909250#post2909250
2417 ''' HeapSort preferred to QuickSort because not recursive (this routine returns an array of indexes !!)
2418 ''' Args:
2420 ''' pbAscending: default = True
2421 ''' pbCaseSensitive: default = False
2422 ''' Returns
2423 ''' An array of Longs of same dimensions as the input array listing the indexes of the sorted items
2424 ''' An empty array if the sort failed
2425 ''' Examples:
2428 Dim vIndexes As Variant ' Return value
2429 Dim i As Long
2430 Dim lMin As Long, lMax As Long ' Array bounds
2431 Dim lSwap As Long ' For index swaps
2433 If IsMissing(pbAscending) Then pbAscending = True
2434 If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
2435 vIndexes = Array()
2436 lMin = LBound(pvArray, 1)
2437 lMax = UBound(pvArray, 1)
2439 ' Initialize output array
2440 ReDim vIndexes(lMin To lMax)
2441 For i = lMin To lMax
2442 vIndexes(i) = i
2443 Next i
2445 ' Initial heapify
2447 SF_Array._HeapSort1(pvArray, vIndexes, i, lMin, lMax, pbCaseSensitive)
2448 Next i
2449 ' Next heapify
2451 ' Only indexes as swapped, not the array items themselves
2452 lSwap = vIndexes(i)
2453 vIndexes(i) = vIndexes(lMin)
2454 vIndexes(lMin) = lSwap
2455 SF_Array._HeapSort1(pvArray, vIndexes, lMin, lMin, i - 1, pbCaseSensitive)
2456 Next i
2458 If pbAscending Then _HeapSort = vIndexes() Else _HeapSort = SF_Array.Reverse(vIndexes())
2460 End Function ' ScriptForge.SF_Array._HeapSort
2462 REM -----------------------------------------------------------------------------
2463 Private Sub _HeapSort1(ByRef pvArray As Variant _
2464 , ByRef pvIndexes As Variant _
2465 , ByVal plIndex As Long _
2466 , ByVal plMin As Long _
2467 , ByVal plMax As Long _
2468 , ByVal pbCaseSensitive As Boolean _
2469 )
2470 ''' Sub called by _HeapSort only
2472 Dim lLeaf As Long
2473 Dim lSwap As Long
2475 Do
2476 lLeaf = plIndex + plIndex - (plMin - 1)
2477 Select Case lLeaf
2478 Case Is > plMax: Exit Do
2479 Case Is < plMax
2480 If SF_Array._ValCompare(pvArray(pvIndexes(lLeaf + 1)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then lLeaf = lLeaf + 1
2481 End Select
2482 If SF_Array._ValCompare(pvArray(pvIndexes(plIndex)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then Exit Do
2483 ' Only indexes as swapped, not the array items themselves
2484 lSwap = pvIndexes(plIndex)
2485 pvIndexes(plIndex) = pvIndexes(lLeaf)
2486 pvIndexes(lLeaf) = lSwap
2487 plIndex = lLeaf
2488 Loop
2490 End Sub ' ScriptForge.SF_Array._HeapSort1
2492 REM -----------------------------------------------------------------------------
2493 Private Function _Repr(ByRef pvArray As Variant) As String
2494 ''' Convert array to a readable string, typically for debugging purposes (DebugPrint ...)
2495 ''' Args:
2496 ''' pvArray: the array to convert, individual items may be of any type, including arrays
2497 ''' Return:
2501 Dim iDims As Integer ' Number of dimensions of the array
2502 Dim sArray As String ' Return value
2503 Dim i As Long
2509 _Repr = ""
2510 iDims = SF_Array.CountDims(pvArray)
2512 Select Case iDims
2514 Case 0 : sArray = cstArrayEmpty
2515 Case Else
2516 sArray = cstArray
2517 For i = 1 To iDims
2518 sArray = sArray & Iif(i = 1, " (", ", ") & CStr(LBound(pvArray, i)) & ":" & CStr(UBound(pvArray, i))
2519 Next i
2522 If iDims = 1 Then
2524 For i = LBound(pvArray) To UBound(pvArray)
2525 sArray = sArray & SF_Utils._Repr(pvArray(i), cstMaxLength) & cstSeparator ' Recursive call
2526 Next i
2527 sArray = Left(sArray, Len(sArray) - Len(cstSeparator)) ' Suppress last comma
2529 End If
2530 End Select
2532 _Repr = sArray
2534 End Function ' ScriptForge.SF_Array._Repr
2536 REM -----------------------------------------------------------------------------
2537 Public Function _StaticType(ByRef pvArray As Variant) As Integer
2538 ''' If array is static, return its type
2539 ''' Args:
2540 ''' pvArray: array to examine
2541 ''' Return:
2543 ''' All numeric types are aggregated into V_NUMERIC
2545 Dim iArrayType As Integer ' VarType of array
2546 Dim iType As Integer ' VarType of items
2548 iArrayType = VarType(pvArray)
2549 iType = iArrayType - V_ARRAY
2550 Select Case iType
2551 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL, V_BOOLEAN
2552 _StaticType = V_NUMERIC
2553 Case V_STRING, V_DATE
2554 _StaticType = iType
2555 Case Else
2556 _StaticType = -1
2557 End Select
2559 End Function ' ScriptForge.SF_Utils._StaticType
2561 REM -----------------------------------------------------------------------------
2562 Private Function _ValCompare(ByVal pvValue1 As Variant _
2563 , pvValue2 As Variant _
2564 , Optional ByVal pbCaseSensitive As Boolean _
2565 ) As Integer
2567 ''' Args:
2568 ''' pvValue1 and pvValue2: values to compare. pvValues must be String, Number, Date, Empty or Null
2570 ''' pbCaseSensitive: ignored when not String comparison
2576 Dim iCompare As Integer, iVarType1 As Integer, iVarType2 As Integer
2578 If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
2579 iVarType1 = SF_Utils._VarTypeExt(pvValue1)
2580 iVarType2 = SF_Utils._VarTypeExt(pvValue2)
2582 iCompare = -2
2584 ElseIf iVarType2 = V_OBJECT Or iVarType2 = V_BYTE Or iVarType2 >= V_ARRAY Then ' Nonsense
2585 ElseIf iVarType1 = V_STRING And iVarType2 = V_STRING Then
2587 ElseIf iVarType1 = V_NULL Or iVarType1 = V_EMPTY Or iVarType2 = V_NULL Or iVarType2 = V_EMPTY Then
2588 Select Case True
2589 Case pvValue1 = pvValue2 : iCompare = 0
2590 Case iVarType1 = V_NULL And iVarType2 = V_EMPTY : iCompare = +1
2591 Case iVarType1 = V_EMPTY And iVarType2 = V_NULL : iCompare = -1
2592 Case iVarType1 = V_NULL Or iVarType1 = V_EMPTY : iCompare = -1
2593 Case iVarType2 = V_NULL Or iVarType2 = V_EMPTY : iCompare = +1
2594 End Select
2595 ElseIf iVarType1 = iVarType2 Then
2596 Select Case True
2598 Case pvValue1 = pvValue2 : iCompare = 0
2600 End Select
2601 End If
2603 _ValCompare = iCompare
2605 End Function ' ScriptForge.SF_Array._ValCompare
2607 REM ================================================= END OF SCRIPTFORGE.SF_ARRAY
2608 </script:module>