| blob | e219a792e134637c1ada907484fb6bd8b40171ae |
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 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
22 REM ================================================================== EXCEPTIONS
25 Const ARRAYINSERTERROR = "ARRAYINSERTERROR" ' Matrix and vector have incompatible sizes
26 Const ARRAYINDEX1ERROR = "ARRAYINDEX1ERROR" ' Given index does not fit in array bounds
27 Const ARRAYINDEX2ERROR = "ARRAYINDEX2ERROR" ' Given indexes do not fit in array bounds
28 Const CSVPARSINGERROR = "CSVPARSINGERROR" ' Parsing error detected while parsing a csv file
29 Const CSVOVERFLOWWARNING = "CSVOVERFLOWWARNING" ' Array becoming too big, import process of csv file is interrupted
31 REM ============================================================ MODULE CONSTANTS
35 REM ===================================================== CONSTRUCTOR/DESTRUCTOR
37 REM -----------------------------------------------------------------------------
38 Public Function Dispose() As Variant
39 Set Dispose = Nothing
40 End Function ' ScriptForge.SF_Array Explicit destructor
42 REM ================================================================== PROPERTIES
44 REM -----------------------------------------------------------------------------
45 Property Get ObjectType As String
46 ''' Only to enable object representation
48 End Property ' ScriptForge.SF_Array.ObjectType
50 REM -----------------------------------------------------------------------------
51 Property Get ServiceName As String
52 ''' Internal use
54 End Property ' ScriptForge.SF_Array.ServiceName
56 REM ============================================================== PUBLIC METHODS
58 REM -----------------------------------------------------------------------------
59 Public Function Append(Optional ByRef Array_1D As Variant _
60 , ParamArray pvArgs() As Variant _
61 ) As Variant
62 ''' Append at the end of the input array the items listed as arguments
63 ''' Arguments are appended blindly
64 ''' each of them might be a scalar of any type or a subarray
65 ''' Args
66 ''' Array_1D: the pre-existing array, may be empty
67 ''' pvArgs: a list of items to append to Array_1D
68 ''' Return:
69 ''' the new extended array. Its LBound is identical to that of Array_1D
70 ''' Examples:
73 Dim vAppend As Variant ' Return value
74 Dim lNbArgs As Long ' Number of elements to append
75 Dim lMax As Long ' UBound of input array
76 Dim i As Long
80 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
81 vAppend = Array()
83 Check:
84 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
86 End If
88 Try:
89 lMax = UBound(Array_1D)
94 End If
95 Else
96 vAppend() = Array_1D()
98 ReDim Preserve vAppend(LBound(Array_1D) To lMax + lNbArgs)
99 End If
100 End If
101 For i = 1 To lNbArgs
102 vAppend(lMax + i) = pvArgs(i - 1)
103 Next i
105 Finally:
106 Append = vAppend()
107 SF_Utils._ExitFunction(cstThisSub)
108 Exit Function
109 Catch:
110 GoTo Finally
111 End Function ' ScriptForge.SF_Array.Append
113 REM -----------------------------------------------------------------------------
114 Public Function AppendColumn(Optional ByRef Array_2D As Variant _
115 , Optional ByRef Column As Variant _
116 ) As Variant
118 ''' Args
119 ''' Array_2D: the pre-existing array, may be empty
120 ''' If the array has 1 dimension, it is considered as the 1st Column of the resulting 2D array
122 ''' Returns:
123 ''' the new extended array. Its LBounds are identical to that of Array_2D
124 ''' Exceptions:
125 ''' ARRAYINSERTERROR
126 ''' Examples:
127 ''' SF_Array.AppendColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 4), (2, 5), (3, 6))
128 ''' x = SF_Array.AppendColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
130 Dim vAppendColumn As Variant ' Return value
131 Dim iDims As Integer ' Dimensions of Array_2D
132 Dim lMin1 As Long ' LBound1 of input array
133 Dim lMax1 As Long ' UBound1 of input array
134 Dim lMin2 As Long ' LBound2 of input array
135 Dim lMax2 As Long ' UBound2 of input array
136 Dim lMin As Long ' LBound of Column array
137 Dim lMax As Long ' UBound of Column array
138 Dim i As Long
139 Dim j As Long
143 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
144 vAppendColumn = Array()
146 Check:
147 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
148 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
150 End If
151 iDims = SF_Array.CountDims(Array_2D)
153 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
154 End If
156 Try:
157 lMin = LBound(Column)
158 lMax = UBound(Column)
160 ' Compute future dimensions of output array
161 Select Case iDims
162 Case 0 : lMin1 = lMin : lMax1 = lMax
168 End Select
170 ReDim vAppendColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
172 ' Copy input array to output array
173 For i = lMin1 To lMax1
174 For j = lMin2 To lMax2
175 If iDims = 2 Then vAppendColumn(i, j) = Array_2D(i, j) Else vAppendColumn(i, j) = Array_2D(i)
176 Next j
177 Next i
178 ' Copy new Column
179 For i = lMin1 To lMax1
180 vAppendColumn(i, lMax2 + 1) = Column(i)
181 Next i
183 Finally:
184 AppendColumn = vAppendColumn()
185 SF_Utils._ExitFunction(cstThisSub)
186 Exit Function
187 Catch:
188 GoTo Finally
189 CatchColumn:
190 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
191 GoTo Finally
192 End Function ' ScriptForge.SF_Array.AppendColumn
194 REM -----------------------------------------------------------------------------
195 Public Function AppendRow(Optional ByRef Array_2D As Variant _
196 , Optional ByRef Row As Variant _
197 ) As Variant
199 ''' Args
200 ''' Array_2D: the pre-existing array, may be empty
201 ''' If the array has 1 dimension, it is considered as the 1st row of the resulting 2D array
203 ''' Returns:
204 ''' the new extended array. Its LBounds are identical to that of Array_2D
205 ''' Exceptions:
206 ''' ARRAYINSERTERROR
207 ''' Examples:
208 ''' SF_Array.AppendRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 2, 3), (4, 5, 6))
209 ''' x = SF_Array.AppendRow(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
211 Dim vAppendRow As Variant ' Return value
212 Dim iDims As Integer ' Dimensions of Array_2D
213 Dim lMin1 As Long ' LBound1 of input array
214 Dim lMax1 As Long ' UBound1 of input array
215 Dim lMin2 As Long ' LBound2 of input array
216 Dim lMax2 As Long ' UBound2 of input array
217 Dim lMin As Long ' LBound of row array
218 Dim lMax As Long ' UBound of row array
219 Dim i As Long
220 Dim j As Long
224 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
225 vAppendRow = Array()
227 Check:
228 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
229 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
231 End If
232 iDims = SF_Array.CountDims(Array_2D)
234 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
235 End If
237 Try:
238 lMin = LBound(Row)
239 lMax = UBound(Row)
241 ' Compute future dimensions of output array
242 Select Case iDims
244 lMin2 = lMin : lMax2 = lMax
249 End Select
251 ReDim vAppendRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
253 ' Copy input array to output array
254 For i = lMin1 To lMax1
255 For j = lMin2 To lMax2
256 If iDims = 2 Then vAppendRow(i, j) = Array_2D(i, j) Else vAppendRow(i, j) = Array_2D(j)
257 Next j
258 Next i
259 ' Copy new row
260 For j = lMin2 To lMax2
261 vAppendRow(lMax1 + 1, j) = Row(j)
262 Next j
264 Finally:
265 AppendRow = vAppendRow()
266 SF_Utils._ExitFunction(cstThisSub)
267 Exit Function
268 Catch:
269 GoTo Finally
270 CatchRow:
271 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
272 GoTo Finally
273 End Function ' ScriptForge.SF_Array.AppendRow
275 REM -----------------------------------------------------------------------------
276 Public Function Contains(Optional ByRef Array_1D As Variant _
277 , Optional ByVal ToFind As Variant _
278 , Optional ByVal CaseSensitive As Variant _
279 , Optional ByVal SortOrder As Variant _
280 ) As Boolean
282 ''' The comparison between strings can be done case-sensitive or not
283 ''' If the array is sorted then
284 ''' the array must be filled homogeneously, i.e. all items must be of the same type
285 ''' Empty and Null items are forbidden
286 ''' a binary search is done
287 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
288 ''' Args:
289 ''' Array_1D: the array to scan
290 ''' ToFind: a number, a date or a string to find
291 ''' CaseSensitive: Only for string comparisons, default = False
292 ''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
293 ''' Return: True when found
294 ''' Result is unpredictable when array is announced sorted and is in reality not
295 ''' Examples:
296 ''' SF_Array.Contains(Array("A","B","c","D"), "C", SortOrder := "ASC") returns True
297 ''' SF_Array.Contains(Array("A","B","c","D"), "C", CaseSensitive := True) returns False
299 Dim bContains As Boolean ' Return value
300 Dim iToFindType As Integer ' VarType of ToFind
302 Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
304 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
306 bContains = False
308 Check:
309 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
310 If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
311 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
312 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
313 If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
314 iToFindType = SF_Utils._VarTypeExt(ToFind)
315 If SortOrder <> "" Then
316 If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, iToFindType) Then GoTo Finally
317 Else
319 End If
320 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
321 End If
323 Try:
324 bContains = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder)(0)
326 Finally:
327 Contains = bContains
328 SF_Utils._ExitFunction(cstThisSub)
329 Exit Function
330 Catch:
331 GoTo Finally
332 End Function ' ScriptForge.SF_Array.Contains
334 REM -----------------------------------------------------------------------------
335 Public Function ConvertToDictionary(Optional ByRef Array_2D As Variant) As Variant
338 ''' Args:
341 ''' Returns:
342 ''' a ScriptForge dictionary object
343 ''' Examples:
344 '''
346 Dim oDict As Variant ' Return value
347 Dim i As Long
351 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
353 Check:
354 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
355 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2, V_STRING, True) Then GoTo Finally
356 End If
358 Try:
362 Next i
364 ConvertToDictionary = oDict
366 Finally:
367 SF_Utils._ExitFunction(cstThisSub)
368 Exit Function
369 Catch:
370 GoTo Finally
371 End Function ' ScriptForge.SF_Array.ConvertToDictionary
373 REM -----------------------------------------------------------------------------
374 Public Function CountDims(Optional ByRef Array_ND As Variant) As Integer
376 ''' Args:
377 ''' Array_ND: the array to be examined
378 ''' Return: the number of dimensions: -1 = not array, 0 = uninitialized array, else >= 1
379 ''' Examples:
383 Dim iDims As Integer ' Return value
384 Dim lMax As Long ' Storage for UBound of each dimension
388 Check:
389 iDims = -1
390 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
391 If IsMissing(Array_ND) Then ' To have missing exception processed
393 End If
394 End If
396 Try:
397 On Local Error Goto ErrHandler
398 ' Loop, increasing the dimension index (i) until an error occurs.
400 iDims = 0
401 If Not IsArray(Array_ND) Then
402 Else
403 Do
404 iDims = iDims + 1
405 lMax = UBound(Array_ND, iDims)
407 End If
409 ErrHandler:
410 On Local Error GoTo 0
412 iDims = iDims - 1
413 If iDims = 1 Then
415 End If
417 Finally:
418 CountDims = iDims
419 SF_Utils._ExitFunction(cstThisSub)
420 Exit Function
421 End Function ' ScriptForge.SF_Array.CountDims
423 REM -----------------------------------------------------------------------------
424 Public Function Difference(Optional ByRef Array1_1D As Variant _
425 , Optional ByRef Array2_1D As Variant _
426 , Optional ByVal CaseSensitive As Variant _
427 ) As Variant
428 ''' Build a set being the Difference of the two input arrays, i.e. items are contained in 1st array and NOT in 2nd
429 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
430 ''' Empty and Null items are forbidden
431 ''' The comparison between strings is case sensitive or not
432 ''' Args:
435 ''' CaseSensitive: default = False
436 ''' Returns: a zero-based array containing unique items from the 1st array not present in the 2nd
437 ''' The output array is sorted in ascending order
438 ''' Examples:
439 ''' SF_Array.Difference(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B")
441 Dim vDifference() As Variant ' Return value
443 Dim iType As Integer ' VarType of elements in input arrays
448 Dim lSize As Long ' Number of Difference items
449 Dim vItem As Variant ' One single item in the array
450 Dim i As Long
454 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
455 vDifference = Array()
457 Check:
458 If IsMissing(CaseSensitive) Then CaseSensitive = False
459 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
461 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
462 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
463 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
464 End If
466 Try:
467 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
468 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
471 If lMax1 < lMin1 Then
473 vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
474 Else
480 ReDim vDifference(0 To (lMax1 - lMin1))
481 lSize = -1
484 For i = lMin1 To lMax1
485 vItem = Array1_1D(i)
487 lSize = lSize + 1
488 vDifference(lSize) = vItem
489 End If
490 Next i
492 ' Remove unfilled entries and duplicates
494 ReDim Preserve vDifference(0 To lSize)
495 vDifference() = SF_Array.Unique(vDifference, CaseSensitive)
496 Else
497 vDifference = Array()
498 End If
499 End If
501 Finally:
502 Difference = vDifference()
503 SF_Utils._ExitFunction(cstThisSub)
504 Exit Function
505 Catch:
506 GoTo Finally
507 End Function ' ScriptForge.SF_Array.Difference
509 REM -----------------------------------------------------------------------------
510 Public Function ExportToTextFile(Optional ByRef Array_1D As Variant _
511 , Optional ByVal FileName As Variant _
512 , Optional ByVal Encoding As Variant _
513 ) As Boolean
514 ''' Write all items of the array sequentially to a text file
515 ''' If the file exists already, it will be overwritten without warning
516 ''' Args:
517 ''' Array_1D: the array to export
518 ''' FileName: the full name (path + file) in SF_FileSystem.FileNaming notation
519 ''' Encoding: The character set that should be used
520 ''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml
521 ''' Note that LibreOffice does not implement all existing sets
523 ''' Returns:
524 ''' True if successful
525 ''' Examples:
526 ''' SF_Array.ExportToTextFile(Array("A","B","C","D"), "C:\Temp\A short file.txt")
528 Dim bExport As Boolean ' Return value
529 Dim oFile As Object ' Output file handler
530 Dim sLine As String ' A single line
534 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
535 bExport = False
537 Check:
539 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
540 If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, V_STRING, True) Then GoTo Finally
543 End If
545 Try:
546 Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True, Encoding := Encoding)
547 If Not IsNull(oFile) Then
548 With oFile
549 For Each sLine In Array_1D
550 .WriteLine(sLine)
551 Next sLine
552 .CloseFile()
553 End With
554 End If
556 bExport = True
558 Finally:
559 If Not IsNull(oFile) Then Set oFile = oFile.Dispose()
560 ExportToTextFile = bExport
561 SF_Utils._ExitFunction(cstThisSub)
562 Exit Function
563 Catch:
564 GoTo Finally
565 End Function ' ScriptForge.SF_Array.ExportToTextFile
567 REM -----------------------------------------------------------------------------
568 Public Function ExtractColumn(Optional ByRef Array_2D As Variant _
569 , Optional ByVal ColumnIndex As Variant _
570 ) As Variant
572 ''' Args
573 ''' Array_2D: the array from which to extract
574 ''' ColumnIndex: the column to extract - must be in the interval [LBound, UBound]
575 ''' Returns:
576 ''' the extracted column. Its LBound and UBound are identical to that of the 1st dimension of Array_2D
577 ''' Exceptions:
578 ''' ARRAYINDEX1ERROR
579 ''' Examples:
584 Dim vExtractColumn As Variant ' Return value
585 Dim lMin1 As Long ' LBound1 of input array
586 Dim lMax1 As Long ' UBound1 of input array
587 Dim lMin2 As Long ' LBound1 of input array
588 Dim lMax2 As Long ' UBound1 of input array
589 Dim i As Long
593 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
594 vExtractColumn = Array()
596 Check:
597 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
600 End If
602 Try:
603 ' Compute future dimensions of output array
607 ReDim vExtractColumn(lMin1 To lMax1)
609 ' Copy Column of input array to output array
610 For i = lMin1 To lMax1
611 vExtractColumn(i) = Array_2D(i, ColumnIndex)
612 Next i
614 Finally:
615 ExtractColumn = vExtractColumn()
616 SF_Utils._ExitFunction(cstThisSub)
617 Exit Function
618 Catch:
619 GoTo Finally
620 CatchIndex:
621 SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "ColumnIndex", SF_Array._Repr(Array_2D), ColumnIndex)
622 GoTo Finally
623 End Function ' ScriptForge.SF_Array.ExtractColumn
625 REM -----------------------------------------------------------------------------
626 Public Function ExtractRow(Optional ByRef Array_2D As Variant _
627 , Optional ByVal RowIndex As Variant _
628 ) As Variant
630 ''' Args
631 ''' Array_2D: the array from which to extract
632 ''' RowIndex: the row to extract - must be in the interval [LBound, UBound]
633 ''' Returns:
634 ''' the extracted row. Its LBound and UBound are identical to that of the 2nd dimension of Array_2D
635 ''' Exceptions:
636 ''' ARRAYINDEX1ERROR
637 ''' Examples:
642 Dim vExtractRow As Variant ' Return value
643 Dim lMin1 As Long ' LBound1 of input array
644 Dim lMax1 As Long ' UBound1 of input array
645 Dim lMin2 As Long ' LBound1 of input array
646 Dim lMax2 As Long ' UBound1 of input array
647 Dim i As Long
651 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
652 vExtractRow = Array()
654 Check:
655 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
658 End If
660 Try:
661 ' Compute future dimensions of output array
665 ReDim vExtractRow(lMin2 To lMax2)
667 ' Copy row of input array to output array
668 For i = lMin2 To lMax2
669 vExtractRow(i) = Array_2D(RowIndex, i)
670 Next i
672 Finally:
673 ExtractRow = vExtractRow()
674 SF_Utils._ExitFunction(cstThisSub)
675 Exit Function
676 Catch:
677 GoTo Finally
678 CatchIndex:
679 SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "RowIndex", SF_Array._Repr(Array_2D), RowIndex)
680 GoTo Finally
681 End Function ' ScriptForge.SF_Array.ExtractRow
683 REM -----------------------------------------------------------------------------
684 Public Function Flatten(Optional ByRef Array_1D As Variant) As Variant
685 ''' Stack all items and all items in subarrays into one array without subarrays
686 ''' Args
687 ''' Array_1D: the pre-existing array, may be empty
688 ''' Return:
689 ''' The new flattened array. Its LBound is identical to that of Array_1D
690 ''' If one of the subarrays has a number of dimensions > 1 Then that subarray is left unchanged
691 ''' Examples:
694 Dim vFlatten As Variant ' Return value
695 Dim lMin As Long ' LBound of input array
696 Dim lMax As Long ' UBound of input array
697 Dim lIndex As Long ' Index in output array
698 Dim vItem As Variant ' Array single item
699 Dim iDims As Integer ' Array number of dimensions
700 Dim lEmpty As Long ' Number of empty subarrays
701 Dim i As Long
702 Dim j As Long
706 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
707 vFlatten = Array()
709 Check:
710 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
712 End If
714 Try:
715 If UBound(Array_1D) >= LBound(Array_1D) Then
716 lMin = LBound(Array_1D) : lMax = UBound(Array_1D)
717 ReDim vFlatten(lMin To lMax) ' Initial minimal sizing
718 lEmpty = 0
719 lIndex = lMin - 1
720 For i = lMin To lMax
721 vItem = Array_1D(i)
722 If IsArray(vItem) Then
723 iDims = SF_Array.CountDims(vItem)
724 Select Case iDims
726 lEmpty = lEmpty + 1
728 ReDim Preserve vFlatten(lMin To UBound(vFlatten) + UBound(vItem) - LBound(vItem))
729 For j = LBound(vItem) To UBound(vItem)
730 lIndex = lIndex + 1
731 vFlatten(lIndex) = vItem(j)
732 Next j
734 lIndex = lIndex + 1
735 vFlatten(lIndex) = vItem
736 End Select
737 Else
738 lIndex = lIndex + 1
739 vFlatten(lIndex) = vItem
740 End If
741 Next i
742 End If
743 ' Reduce size of output if Array_1D is populated with some empty arrays
745 If lIndex - lEmpty < lMin Then
746 vFlatten = Array()
747 Else
748 ReDim Preserve vFlatten(lMin To UBound(vFlatten) - lEmpty)
749 End If
750 End If
752 Finally:
753 Flatten = vFlatten()
754 SF_Utils._ExitFunction(cstThisSub)
755 Exit Function
756 Catch:
757 GoTo Finally
758 End Function ' ScriptForge.SF_Array.Flatten
760 REM -----------------------------------------------------------------------------
761 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
762 ''' Return the actual value of the given property
763 ''' Args:
764 ''' PropertyName: the name of the property as a string
765 ''' Returns:
766 ''' The actual value of the property
767 ''' Exceptions
768 ''' ARGUMENTERROR The property does not exist
773 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
774 GetProperty = Null
776 Check:
777 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
778 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
779 End If
781 Try:
782 Select Case UCase(PropertyName)
783 Case Else
784 End Select
786 Finally:
787 SF_Utils._ExitFunction(cstThisSub)
788 Exit Function
789 Catch:
790 GoTo Finally
791 End Function ' ScriptForge.SF_Array.GetProperty
793 REM -----------------------------------------------------------------------------
794 Public Function ImportFromCSVFile(Optional ByRef FileName As Variant _
795 , Optional ByVal Delimiter As Variant _
796 , Optional ByVal DateFormat As Variant _
797 ) As Variant
798 ''' Import the data contained in a comma-separated values (CSV) file
799 ''' The comma may be replaced by any character
800 ''' Each line in the file contains a full record
801 ''' Line splitting is not allowed)
802 ''' However sequences like \n, \t, ... are left unchanged. Use SF_String.Unescape() to manage them
803 ''' A special mechanism is implemented to load dates
804 ''' The applicable CSV format is described in https://tools.ietf.org/html/rfc4180
805 ''' Args:
806 ''' FileName: the name of the text file containing the data expressed as given by the current FileNaming
807 ''' property of the SF_FileSystem service. Default = both URL format or native format
808 ''' Delimiter: Default = ",". Other usual options are ";" and the tab character
809 ''' DateFormat: either YYYY-MM-DD, DD-MM-YYYY or MM-DD-YYYY
810 ''' The dash (-) may be replaced by a dot (.), a slash (/) or a space
811 ''' Other date formats will be ignored
813 ''' Returns:
815 ''' and each column corresponding with a field of the record
816 ''' No check is made about the coherence of the field types across columns
817 ''' A best guess will be made to identify numeric and date types
818 ''' If a line contains less or more fields than the first line in the file,
819 ''' an exception will be raised. Empty lines however are simply ignored
820 ''' If the size of the file exceeds the number of items limit, a warning is raised
821 ''' and the array is truncated
822 ''' Exceptions:
823 ''' CSVPARSINGERROR Given file is not formatted as a csv file
824 ''' CSVOVERFLOWWARNING Maximum number of allowed items exceeded
826 Dim vArray As Variant ' Returned array
827 Dim lCol As Long ' Index of last column of vArray
828 Dim lRow As Long ' Index of current row of vArray
829 Dim lFileSize As Long ' Number of records found in the file
830 Dim vCsv As Object ' CSV file handler
831 Dim sLine As String ' Last read line
832 Dim vLine As Variant ' Array of fields of last read line
833 Dim sItem As String ' Individual item in the file
834 Dim vItem As Variant ' Individual item in the output array
835 Dim iPosition As Integer ' Date position in individual item
836 Dim iYear As Integer, iMonth As Integer, iDay As Integer
837 ' Date components
838 Dim i As Long
841 Const cstSubArgs = "FileName, [Delimiter="",""], [DateFormat=""""]"
843 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
844 vArray = Array()
846 Check:
848 If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat = ""
849 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
853 End If
856 Try:
857 ' Counts the lines present in the file to size the final array
858 ' Very beneficial for large files, better than multiple ReDims
859 ' Small overhead for small files
860 lFileSize = SF_FileSystem._CountTextLines(FileName, False)
863 ' Reread file line by line
864 Set vCsv = SF_FileSystem.OpenTextFile(FileName, IOMode := SF_FileSystem.ForReading)
865 If IsNull(vCsv) Then GoTo Finally ' Open error
866 lRow = -1
867 With vCsv
868 Do While Not .AtEndOfStream
869 sLine = .ReadLine()
871 If InStr(sLine, """") > 0 Then vLine = SF_String.SplitNotQuoted(sLine, Delimiter) Else vLine = Split(sLine, Delimiter) ' Simple split when relevant
872 lRow = lRow + 1
874 lCol = UBound(vLine)
876 ElseIf UBound(vLine) <> lCol Then
877 GoTo CatchCSVFormat
878 End If
879 ' Check type and copy all items of the line
880 For i = 0 To lCol
881 If Left(vLine(i), 1) = """" Then sItem = SF_String.Unquote(vLine(i)) Else sItem = vLine(i) ' Unquote only when useful
882 ' Interpret the individual line item
883 Select Case True
884 Case IsNumeric(sItem)
885 If InStr(sItem, ".") + InStr(1, sItem, "e", 1) > 0 Then vItem = Val(sItem) Else vItem = CLng(sItem)
886 Case DateFormat <> "" And Len(sItem) = Len(DateFormat)
887 If SF_String.IsADate(sItem, DateFormat) Then
891 vItem = DateSerial(iYear, iMonth, iDay)
892 Else
893 vItem = sItem
894 End If
895 Case Else : vItem = sItem
896 End Select
897 vArray(lRow, i) = vItem
898 Next i
899 End If
900 ' Provision to avoid very large arrays and their sometimes erratic behaviour
903 GoTo CatchOverflow
904 End If
905 Loop
906 End With
908 Finally:
909 If Not IsNull(vCsv) Then
910 vCsv.CloseFile()
911 Set vCsv = vCsv.Dispose()
912 End If
913 ImportFromCSVFile = vArray
914 SF_Utils._ExitFunction(cstThisSub)
915 Exit Function
916 Catch:
917 GoTo Finally
918 CatchCSVFormat:
919 SF_Exception.RaiseFatal(CSVPARSINGERROR, FileName, vCsv.Line, sLine)
920 GoTo Finally
921 CatchOverflow:
922 'TODO SF_Exception.RaiseWarning(SF_Exception.CSVOVERFLOWWARNING, cstThisSub)
924 GoTo Finally
925 End Function ' ScriptForge.SF_Array.ImportFromCSVFile
927 REM -----------------------------------------------------------------------------
928 Public Function IndexOf(Optional ByRef Array_1D As Variant _
929 , Optional ByVal ToFind As Variant _
930 , Optional ByVal CaseSensitive As Variant _
931 , Optional ByVal SortOrder As Variant _
932 ) As Long
934 ''' ToFind must exist within the array.
935 ''' The comparison between strings can be done case-sensitively or not
936 ''' If the array is sorted then
937 ''' the array must be filled homogeneously, i.e. all items must be of the same type
938 ''' Empty and Null items are forbidden
939 ''' a binary search is done
940 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
941 ''' Args:
942 ''' Array_1D: the array to scan
943 ''' ToFind: a number, a date or a string to find
944 ''' CaseSensitive: Only for string comparisons, default = False
945 ''' SortOrder: "ASC", "DESC" or "" (= not sorted, default)
947 ''' Result is unpredictable when array is announced sorted and is in reality not
948 ''' Examples:
949 ''' SF_Array.IndexOf(Array("A","B","c","D"), "C", SortOrder := "ASC") returns 2
950 ''' SF_Array.IndexOf(Array("A","B","c","D"), "C", CaseSensitive := True) returns -1
953 Dim lIndex As Long ' Return value
954 Dim iToFindType As Integer ' VarType of ToFind
956 Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]"
958 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
960 lIndex = -1
962 Check:
963 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
964 If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = ""
965 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
966 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally
967 If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
968 iToFindType = SF_Utils._VarTypeExt(ToFind)
969 If SortOrder <> "" Then
971 Else
973 End If
974 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
975 End If
977 Try:
978 vFindItem = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder)
981 Finally:
982 IndexOf = lIndex
983 SF_Utils._ExitFunction(cstThisSub)
984 Exit Function
985 Catch:
986 GoTo Finally
987 End Function ' ScriptForge.SF_Array.IndexOf
989 REM -----------------------------------------------------------------------------
990 Public Function Insert(Optional ByRef Array_1D As Variant _
991 , Optional ByVal Before As Variant _
992 , ParamArray pvArgs() As Variant _
993 ) As Variant
994 ''' Insert before the index Before of the input array the items listed as arguments
995 ''' Arguments are inserted blindly
996 ''' each of them might be a scalar of any type or a subarray
997 ''' Args
998 ''' Array_1D: the pre-existing array, may be empty
999 ''' Before: the index before which to insert; must be in the interval [LBound, UBound + 1]
1000 ''' pvArgs: a list of items to Insert inside Array_1D
1001 ''' Returns:
1002 ''' the new rxtended array. Its LBound is identical to that of Array_1D
1003 ''' Exceptions:
1004 ''' ARRAYINSERTERROR
1005 ''' Examples:
1008 Dim vInsert As Variant ' Return value
1009 Dim lNbArgs As Long ' Number of elements to Insert
1010 Dim lMin As Long ' LBound of input array
1011 Dim lMax As Long ' UBound of input array
1012 Dim i As Long
1016 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1017 vInsert = Array()
1019 Check:
1020 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1024 End If
1026 Try:
1028 lMin = LBound(Array_1D) ' = LBound(vInsert)
1029 lMax = UBound(Array_1D) ' <> UBound(vInsert)
1031 ReDim vInsert(lMin To lMax + lNbArgs)
1032 For i = lMin To UBound(vInsert)
1033 If i < Before Then
1034 vInsert(i) = Array_1D(i)
1035 ElseIf i < Before + lNbArgs Then
1036 vInsert(i) = pvArgs(i - Before)
1037 Else
1038 vInsert(i) = Array_1D(i - lNbArgs)
1039 End If
1040 Next i
1041 Else
1042 vInsert() = Array_1D()
1043 End If
1045 Finally:
1046 Insert = vInsert()
1047 SF_Utils._ExitFunction(cstThisSub)
1048 Exit Function
1049 Catch:
1050 GoTo Finally
1051 CatchArgument:
1052 'TODO SF_Exception.RaiseFatal(ARRAYINSERTERROR, cstThisSub)
1054 GoTo Finally
1055 End Function ' ScriptForge.SF_Array.Insert
1057 REM -----------------------------------------------------------------------------
1058 Public Function InsertSorted(Optional ByRef Array_1D As Variant _
1059 , Optional ByVal Item As Variant _
1060 , Optional ByVal SortOrder As Variant _
1061 , Optional ByVal CaseSensitive As Variant _
1062 ) As Variant
1063 ''' Insert in a sorted array a new item on its place
1064 ''' the array must be filled homogeneously, i.e. all items must be of the same type
1065 ''' Empty and Null items are forbidden
1066 ''' Args:
1067 ''' Array_1D: the array to sort
1068 ''' Item: the scalar value to insert, same type as the existing array items
1070 ''' CaseSensitive: Default = False
1071 ''' Returns: the extended sorted array with same LBound as input array
1072 ''' Examples:
1073 ''' InsertSorted(Array("A", "C", "a", "b"), "B", CaseSensitive := True) returns ("A", "B", "C", "a", "b")
1075 Dim vSorted() As Variant ' Return value
1076 Dim iType As Integer ' VarType of elements in input array
1077 Dim lMin As Long ' LBound of input array
1078 Dim lMax As Long ' UBound of input array
1079 Dim lIndex As Long ' Place where to insert new item
1081 Const cstSubArgs = "Array_1D, Item, [SortOrder=""ASC""|""DESC""], [CaseSensitive=False]"
1083 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1084 vSorted = Array()
1086 Check:
1088 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1089 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1091 If LBound(Array_1D) <= UBound(Array_1D) Then
1092 iType = SF_Utils._VarTypeExt(Array_1D(LBound(Array_1D)))
1094 Else
1095 If Not SF_Utils._Validate(Item, "Item", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally
1096 End If
1097 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1098 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1099 End If
1101 Try:
1102 lMin = LBound(Array_1D)
1103 lMax = UBound(Array_1D)
1104 lIndex = SF_Array._FindItem(Array_1D, Item, CaseSensitive, SortOrder)(1)
1105 vSorted = SF_Array.Insert(Array_1D, lIndex, Item)
1107 Finally:
1108 InsertSorted = vSorted()
1109 SF_Utils._ExitFunction(cstThisSub)
1110 Exit Function
1111 Catch:
1112 GoTo Finally
1113 End Function ' ScriptForge.SF_Array.InsertSorted
1115 REM -----------------------------------------------------------------------------
1116 Public Function Intersection(Optional ByRef Array1_1D As Variant _
1117 , Optional ByRef Array2_1D As Variant _
1118 , Optional ByVal CaseSensitive As Variant _
1119 ) As Variant
1120 ''' Build a set being the intersection of the two input arrays, i.e. items are contained in both arrays
1121 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
1122 ''' Empty and Null items are forbidden
1123 ''' The comparison between strings is case sensitive or not
1124 ''' Args:
1127 ''' CaseSensitive: default = False
1128 ''' Returns: a zero-based array containing unique items stored in both input arrays
1129 ''' The output array is sorted in ascending order
1130 ''' Examples:
1131 ''' Intersection(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("C", "b")
1133 Dim vIntersection() As Variant ' Return value
1134 Dim vSorted() As Variant ' The shortest input array after sort
1135 Dim iType As Integer ' VarType of elements in input arrays
1140 Dim lMin As Long ' LBound of unsorted array
1141 Dim lMax As Long ' UBound of unsorted array
1143 Dim lSize As Long ' Number of Intersection items
1144 Dim vItem As Variant ' One single item in the array
1145 Dim i As Long
1149 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1150 vIntersection = Array()
1152 Check:
1153 If IsMissing(CaseSensitive) Then CaseSensitive = False
1154 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1156 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
1157 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
1158 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1159 End If
1161 Try:
1162 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
1163 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
1165 ' If one of both arrays is empty, do nothing
1168 ' First sort the shortest array
1169 If lMax1 - lMin1 <= lMax2 - lMin2 Then
1170 iShortest = 1
1172 lMin = lMin2 : lMax = lMax2 ' Bounds of unsorted array
1173 Else
1174 iShortest = 2
1176 lMin = lMin1 : lMax = lMax1 ' Bounds of unsorted array
1177 End If
1179 ' Resize the output array to the size of the shortest array
1180 ReDim vIntersection(0 To (lMax - lMin))
1181 lSize = -1
1183 ' Fill vIntersection one by one only with items present in both sets
1184 For i = lMin To lMax
1185 If iShortest = 1 Then vItem = Array2_1D(i) Else vItem = Array1_1D(i) ' Pick in unsorted array
1187 lSize = lSize + 1
1188 vIntersection(lSize) = vItem
1189 End If
1190 Next i
1192 ' Remove unfilled entries and duplicates
1194 ReDim Preserve vIntersection(0 To lSize)
1195 vIntersection() = SF_Array.Unique(vIntersection, CaseSensitive)
1196 Else
1197 vIntersection = Array()
1198 End If
1199 End If
1201 Finally:
1202 Intersection = vIntersection()
1203 SF_Utils._ExitFunction(cstThisSub)
1204 Exit Function
1205 Catch:
1206 GoTo Finally
1207 End Function ' ScriptForge.SF_Array.Intersection
1209 REM -----------------------------------------------------------------------------
1210 Public Function Join2D(Optional ByRef Array_2D As Variant _
1211 , Optional ByVal ColumnDelimiter As Variant _
1212 , Optional ByVal RowDelimiter As Variant _
1213 , Optional ByVal Quote As Variant _
1214 ) As String
1215 ''' Join a two-dimensional array with two delimiters, one for columns, one for rows
1216 ''' Args:
1217 ''' Array_2D: each item must be either a String, a number, a Date or a Boolean
1220 ''' Quote: if True, protect strings with double quotes (default = False)
1221 ''' Return:
1222 ''' A string after conversion of numbers and dates
1223 ''' Invalid items are replaced by a zero-length string
1224 ''' Examples:
1226 ''' SF_Array.Join_2D( | 6, 7, "this is a string", 9, 10 | , ",", "/")
1229 Dim sJoin As String ' The return value
1230 Dim sItem As String ' The string representation of a single item
1231 Dim vItem As Variant ' Single item
1232 Dim lMin1 As Long ' LBound1 of input array
1233 Dim lMax1 As Long ' UBound1 of input array
1234 Dim lMin2 As Long ' LBound2 of input array
1235 Dim lMax2 As Long ' UBound2 of input array
1236 Dim i As Long
1237 Dim j As Long
1239 Const cstSubArgs = "Array_2D, [ColumnDelimiter=Chr(9)], [RowDelimiter=Chr(10)], [Quote=False]"
1241 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1242 sJoin = ""
1244 Check:
1245 If IsMissing(ColumnDelimiter) Or IsEmpty(ColumnDelimiter) Then ColumnDelimiter = Chr(9)
1246 If IsMissing(RowDelimiter) Or IsEmpty(RowDelimiter) Then RowDelimiter = Chr(10)
1247 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1249 If Not SF_Utils._Validate(ColumnDelimiter, "ColumnDelimiter", V_STRING) Then GoTo Finally
1252 End If
1254 Try:
1257 If lMin1 <= lMax1 Then
1258 For i = lMin1 To lMax1
1259 For j = lMin2 To lMax2
1260 vItem = Array_2D(i, j)
1261 Select Case SF_Utils._VarTypeExt(vItem)
1262 Case V_STRING : If Quote Then sItem = SF_String.Quote(vItem) Else sItem = vItem
1263 Case V_NUMERIC, V_DATE : sItem = SF_Utils._Repr(vItem)
1265 Case Else : sItem = ""
1266 End Select
1268 Next j
1270 Next i
1271 End If
1273 Finally:
1274 Join2D = sJoin
1275 SF_Utils._ExitFunction(cstThisSub)
1276 Exit Function
1277 Catch:
1278 GoTo Finally
1279 End Function ' ScriptForge.SF_Array.Join2D
1281 REM -----------------------------------------------------------------------------
1282 Public Function Methods() As Variant
1283 ''' Return the list of public methods of the Array service as an array
1285 Methods = Array( _
1316 )
1318 End Function ' ScriptForge.SF_Array.Methods
1320 REM -----------------------------------------------------------------------------
1321 Public Function Prepend(Optional ByRef Array_1D As Variant _
1322 , ParamArray pvArgs() As Variant _
1323 ) As Variant
1324 ''' Prepend at the beginning of the input array the items listed as arguments
1325 ''' Arguments are Prepended blindly
1326 ''' each of them might be a scalar of any type or a subarray
1327 ''' Args
1328 ''' Array_1D: the pre-existing array, may be empty
1329 ''' pvArgs: a list of items to Prepend to Array_1D
1330 ''' Return: the new rxtended array. Its LBound is identical to that of Array_1D
1331 ''' Examples:
1334 Dim vPrepend As Variant ' Return value
1335 Dim lNbArgs As Long ' Number of elements to Prepend
1336 Dim lMin As Long ' LBound of input array
1337 Dim lMax As Long ' UBound of input array
1338 Dim i As Long
1342 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1343 vPrepend = Array()
1345 Check:
1346 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1348 End If
1350 Try:
1352 lMin = LBound(Array_1D) ' = LBound(vPrepend)
1353 lMax = UBound(Array_1D) ' <> UBound(vPrepend)
1356 Else
1357 ReDim vPrepend(lMin To lMax + lNbArgs)
1358 End If
1359 For i = lMin To UBound(vPrepend)
1360 If i < lMin + lNbArgs Then vPrepend(i) = pvArgs(i - lMin) Else vPrepend(i) = Array_1D(i - lNbArgs)
1361 Next i
1363 Finally:
1364 Prepend = vPrepend
1365 SF_Utils._ExitFunction(cstThisSub)
1366 Exit Function
1367 Catch:
1368 GoTo Finally
1369 End Function ' ScriptForge.SF_Array.Prepend
1371 REM -----------------------------------------------------------------------------
1372 Public Function PrependColumn(Optional ByRef Array_2D As Variant _
1373 , Optional ByRef Column As Variant _
1374 ) As Variant
1376 ''' Args
1377 ''' Array_2D: the pre-existing array, may be empty
1378 ''' If the array has 1 dimension, it is considered as the last Column of the resulting 2D array
1380 ''' Returns:
1381 ''' the new rxtended array. Its LBounds are identical to that of Array_2D
1382 ''' Exceptions:
1383 ''' ARRAYINSERTERROR
1384 ''' Examples:
1385 ''' SF_Array.PrependColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 1), (5, 2), (6, 3))
1386 ''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i
1388 Dim vPrependColumn As Variant ' Return value
1389 Dim iDims As Integer ' Dimensions of Array_2D
1390 Dim lMin1 As Long ' LBound1 of input array
1391 Dim lMax1 As Long ' UBound1 of input array
1392 Dim lMin2 As Long ' LBound2 of input array
1393 Dim lMax2 As Long ' UBound2 of input array
1394 Dim lMin As Long ' LBound of Column array
1395 Dim lMax As Long ' UBound of Column array
1396 Dim i As Long
1397 Dim j As Long
1401 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1402 vPrependColumn = Array()
1404 Check:
1405 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1406 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
1408 End If
1409 iDims = SF_Array.CountDims(Array_2D)
1411 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
1412 End If
1414 Try:
1415 lMin = LBound(Column)
1416 lMax = UBound(Column)
1418 ' Compute future dimensions of output array
1419 Select Case iDims
1420 Case 0 : lMin1 = lMin : lMax1 = lMax
1426 End Select
1428 ReDim vPrependColumn(lMin1 To lMax1, lMin2 To lMax2 + 1)
1430 ' Copy input array to output array
1431 For i = lMin1 To lMax1
1433 If iDims = 2 Then vPrependColumn(i, j) = Array_2D(i, j - 1) Else vPrependColumn(i, j) = Array_2D(i)
1434 Next j
1435 Next i
1436 ' Copy new Column
1437 For i = lMin1 To lMax1
1438 vPrependColumn(i, lMin2) = Column(i)
1439 Next i
1441 Finally:
1442 PrependColumn = vPrependColumn()
1443 SF_Utils._ExitFunction(cstThisSub)
1444 Exit Function
1445 Catch:
1446 GoTo Finally
1447 CatchColumn:
1448 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR))
1449 GoTo Finally
1450 End Function ' ScriptForge.SF_Array.PrependColumn
1452 REM -----------------------------------------------------------------------------
1453 Public Function PrependRow(Optional ByRef Array_2D As Variant _
1454 , Optional ByRef Row As Variant _
1455 ) As Variant
1457 ''' Args
1458 ''' Array_2D: the pre-existing array, may be empty
1459 ''' If the array has 1 dimension, it is considered as the last row of the resulting 2D array
1461 ''' Returns:
1462 ''' the new rxtended array. Its LBounds are identical to that of Array_2D
1463 ''' Exceptions:
1464 ''' ARRAYINSERTERROR
1465 ''' Examples:
1466 ''' SF_Array.PrependRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 5, 6), (1, 2, 3))
1467 ''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i
1469 Dim vPrependRow As Variant ' Return value
1470 Dim iDims As Integer ' Dimensions of Array_2D
1471 Dim lMin1 As Long ' LBound1 of input array
1472 Dim lMax1 As Long ' UBound1 of input array
1473 Dim lMin2 As Long ' LBound2 of input array
1474 Dim lMax2 As Long ' UBound2 of input array
1475 Dim lMin As Long ' LBound of row array
1476 Dim lMax As Long ' UBound of row array
1477 Dim i As Long
1478 Dim j As Long
1482 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1483 vPrependRow = Array()
1485 Check:
1486 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1487 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array
1489 End If
1490 iDims = SF_Array.CountDims(Array_2D)
1492 If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error
1493 End If
1495 Try:
1496 lMin = LBound(Row)
1497 lMax = UBound(Row)
1499 ' Compute future dimensions of output array
1500 Select Case iDims
1502 lMin2 = lMin : lMax2 = lMax
1507 End Select
1509 ReDim vPrependRow(lMin1 To lMax1 + 1, lMin2 To lMax2)
1511 ' Copy input array to output array
1513 For j = lMin2 To lMax2
1515 Next j
1516 Next i
1517 ' Copy new row
1518 For j = lMin2 To lMax2
1519 vPrependRow(lMin1, j) = Row(j)
1520 Next j
1522 Finally:
1523 PrependRow = vPrependRow()
1524 SF_Utils._ExitFunction(cstThisSub)
1525 Exit Function
1526 Catch:
1527 GoTo Finally
1528 CatchRow:
1529 SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR))
1530 GoTo Finally
1531 End Function ' ScriptForge.SF_Array.PrependRow
1533 REM -----------------------------------------------------------------------------
1534 Public Function Properties() As Variant
1535 ''' Return the list or properties as an array
1537 Properties = Array( _
1538 )
1540 End Function ' ScriptForge.SF_Array.Properties
1542 REM -----------------------------------------------------------------------------
1543 Public Function RangeInit(Optional ByVal From As Variant _
1544 , Optional ByVal UpTo As Variant _
1545 , Optional ByVal ByStep As Variant _
1546 ) As Variant
1547 ''' Initialize a new zero-based array with numeric values
1548 ''' Args: all numeric
1549 ''' From: value of first item
1550 ''' UpTo: last item should not exceed UpTo
1552 ''' Return: the new array
1553 ''' Exceptions:
1555 ''' Examples:
1558 Dim lIndex As Long ' Index of array
1559 Dim lSize As Long ' UBound of resulting array
1560 Dim vCurrentItem As Variant ' Last stored item
1561 Dim vArray() ' The return value
1565 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1566 vArray = Array()
1568 Check:
1569 If IsMissing(ByStep) Or IsEmpty(ByStep) Then ByStep = 1
1570 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1574 End If
1575 If (From < UpTo And ByStep <= 0) Or (From > UpTo And ByStep >= 0) Then GoTo CatchSequence
1577 Try:
1578 lSize = CLng(Abs((UpTo - From) / ByStep))
1579 ReDim vArray(0 To lSize)
1580 For lIndex = 0 To lSize
1581 vArray(lIndex) = From + lIndex * ByStep
1582 Next lIndex
1584 Finally:
1585 RangeInit = vArray
1586 SF_Utils._ExitFunction(cstThisSub)
1587 Exit Function
1588 Catch:
1589 GoTo Finally
1590 CatchSequence:
1591 SF_Exception.RaiseFatal(ARRAYSEQUENCEERROR, From, UpTo, ByStep)
1592 GoTo Finally
1593 End Function ' ScriptForge.SF_Array.RangeInit
1595 REM -----------------------------------------------------------------------------
1596 Public Function Reverse(Optional ByRef Array_1D As Variant) As Variant
1598 ''' Args:
1599 ''' Array_1D: the array to reverse
1600 ''' Returns: the reversed array
1601 ''' Examples:
1604 Dim vReverse() As Variant ' Return value
1605 Dim lHalf As Long ' Middle of array
1606 Dim lMin As Long ' LBound of input array
1607 Dim lMax As Long ' UBound of input array
1608 Dim i As Long, j As Long
1612 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1613 vReverse = Array()
1615 Check:
1616 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1618 End If
1620 Try:
1621 lMin = LBound(Array_1D)
1622 lMax = UBound(Array_1D)
1623 ReDim vReverse(lMin To lMax)
1624 lHalf = Int((lMax + lMin) / 2)
1625 j = lMax
1626 For i = lMin To lHalf
1627 vReverse(i) = Array_1D(j)
1628 vReverse(j) = Array_1D(i)
1629 j = j - 1
1630 Next i
1631 ' Odd number of items
1634 Finally:
1635 Reverse = vReverse()
1636 SF_Utils._ExitFunction(cstThisSub)
1637 Exit Function
1638 Catch:
1639 GoTo Finally
1640 End Function ' ScriptForge.SF_Array.Reverse
1642 REM -----------------------------------------------------------------------------
1643 Public Function SetProperty(Optional ByVal PropertyName As Variant _
1644 , Optional ByRef Value As Variant _
1645 ) As Boolean
1646 ''' Set a new value to the given property
1647 ''' Args:
1648 ''' PropertyName: the name of the property as a string
1649 ''' Value: its new value
1650 ''' Exceptions
1651 ''' ARGUMENTERROR The property does not exist
1656 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1657 SetProperty = False
1659 Check:
1660 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1661 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
1662 End If
1664 Try:
1665 Select Case UCase(PropertyName)
1666 Case Else
1667 End Select
1669 Finally:
1670 SF_Utils._ExitFunction(cstThisSub)
1671 Exit Function
1672 Catch:
1673 GoTo Finally
1674 End Function ' ScriptForge.SF_Array.SetProperty
1676 REM -----------------------------------------------------------------------------
1677 Public Function Shuffle(Optional ByRef Array_1D As Variant) As Variant
1680 ''' Args:
1681 ''' Array_1D: the array to shuffle
1682 ''' Returns: the shuffled array
1684 Dim vShuffle() As Variant ' Return value
1685 Dim vSwapValue As Variant ' Intermediate value during swap
1686 Dim lMin As Long ' LBound of Array_1D
1687 Dim lCurrentIndex As Long ' Decremented from UBount to LBound
1688 Dim lRandomIndex As Long ' Random between LBound and lCurrentIndex
1689 Dim i As Long
1693 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1694 vShuffle = Array()
1696 Check:
1697 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1699 End If
1701 Try:
1702 lMin = LBound(Array_1D)
1703 lCurrentIndex = UBound(array_1D)
1704 ' Initialize the output array
1705 ReDim vShuffle(lMin To lCurrentIndex)
1706 For i = lMin To lCurrentIndex
1707 vShuffle(i) = Array_1D(i)
1708 Next i
1709 ' Now ... shuffle !
1710 Do While lCurrentIndex > lMin
1711 lRandomIndex = Int(Rnd * (lCurrentIndex - lMin)) + lMin
1712 vSwapValue = vShuffle(lCurrentIndex)
1713 vShuffle(lCurrentIndex) = vShuffle(lRandomIndex)
1714 vShuffle(lRandomIndex) = vSwapValue
1715 lCurrentIndex = lCurrentIndex - 1
1716 Loop
1718 Finally:
1719 Shuffle = vShuffle()
1720 SF_Utils._ExitFunction(cstThisSub)
1721 Exit Function
1722 Catch:
1723 GoTo Finally
1724 End Function ' ScriptForge.SF_Array.Shuffle
1726 REM -----------------------------------------------------------------------------
1727 Public Function Slice(Optional ByRef Array_1D As Variant _
1728 , Optional ByVal From As Variant _
1729 , Optional ByVal UpTo As Variant _
1730 ) As Variant
1732 ''' Args:
1733 ''' Array_1D: the array to slice
1734 ''' From: the lower index of the subarray to extract (included)
1735 ''' UpTo: the upper index of the subarray to extract (included). Default = the last item of Array_1D
1736 ''' Returns:
1737 ''' The selected subarray with the same LBound as the input array.
1739 ''' Exceptions:
1740 ''' ARRAYINDEX2ERROR Wrong values for From and/or UpTo
1741 ''' Example:
1744 Dim vSlice() As Variant ' Return value
1745 Dim lMin As Long ' LBound of Array_1D
1746 Dim lIndex As Long ' Current index in output array
1747 Dim i As Long
1751 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1752 vSlice = Array()
1754 Check:
1755 If IsMissing(UpTo) Or IsEmpty(UpTo) Then UpTo = -1
1756 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1760 End If
1761 If UpTo = -1 Then UpTo = UBound(Array_1D)
1765 Try:
1766 If UpTo >= From Then
1767 lMin = LBound(Array_1D)
1768 ' Initialize the output array
1769 ReDim vSlice(lMin To lMin + UpTo - From)
1770 lIndex = lMin - 1
1771 For i = From To UpTo
1772 lIndex = lIndex + 1
1773 vSlice(lIndex) = Array_1D(i)
1774 Next i
1775 End If
1777 Finally:
1778 Slice = vSlice()
1779 SF_Utils._ExitFunction(cstThisSub)
1780 Exit Function
1781 Catch:
1782 GoTo Finally
1783 CatchIndex:
1784 SF_Exception.RaiseFatal(ARRAYINDEX2ERROR, SF_Array._Repr(Array_1D), From, UpTo)
1785 GoTo Finally
1786 End Function ' ScriptForge.SF_Array.Slice
1788 REM -----------------------------------------------------------------------------
1789 Public Function Sort(Optional ByRef Array_1D As Variant _
1790 , Optional ByVal SortOrder As Variant _
1791 , Optional ByVal CaseSensitive As Variant _
1792 ) As Variant
1793 ''' Sort a 1D array in ascending or descending order. String comparisons can be case-sensitive or not
1794 ''' Args:
1795 ''' Array_1D: the array to sort
1796 ''' must be filled homogeneously by either strings, dates or numbers
1797 ''' Null and Empty values are allowed
1799 ''' CaseSensitive: Default = False
1800 ''' Returns: the sorted array
1801 ''' Examples:
1802 ''' Sort(Array("a", "A", "b", "B", "C"), CaseSensitive := True) returns ("A", "B", "C", "a", "b")
1804 Dim vSort() As Variant ' Return value
1805 Dim vIndexes() As Variant ' Indexes of sorted items
1806 Dim lMin As Long ' LBound of input array
1807 Dim lMax As Long ' UBound of input array
1808 Dim i As Long
1810 Const cstSubArgs = "Array_1D, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
1812 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1813 vSort = Array()
1815 Check:
1817 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1818 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1820 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1821 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1822 End If
1824 Try:
1825 lMin = LBound(Array_1D)
1826 lMax = UBound(Array_1D)
1829 ' Load output array
1830 ReDim vSort(lMin To lMax)
1831 For i = lMin To lMax
1832 vSort(i) = Array_1D(vIndexes(i))
1833 Next i
1835 Finally:
1836 Sort = vSort()
1837 SF_Utils._ExitFunction(cstThisSub)
1838 Exit Function
1839 Catch:
1840 GoTo Finally
1841 End Function ' ScriptForge.SF_Array.Sort
1843 REM -----------------------------------------------------------------------------
1844 Public Function SortColumns(Optional ByRef Array_2D As Variant _
1845 , Optional ByVal RowIndex As Variant _
1846 , Optional ByVal SortOrder As Variant _
1847 , Optional ByVal CaseSensitive As Variant _
1848 ) As Variant
1849 ''' Returns a permutation of the columns of a 2D array, sorted on the values of a given row
1850 ''' Args:
1851 ''' Array_2D: the input array
1852 ''' RowIndex: the index of the row to sort the columns on
1853 ''' the row must be filled homogeneously by either strings, dates or numbers
1854 ''' Null and Empty values are allowed
1856 ''' CaseSensitive: Default = False
1857 ''' Returns:
1858 ''' the array with permuted columns, LBounds and UBounds are unchanged
1859 ''' Exceptions:
1860 ''' ARRAYINDEXERROR
1861 ''' Examples:
1866 Dim vSort() As Variant ' Return value
1867 Dim vRow() As Variant ' The row on which to sort the array
1868 Dim vIndexes() As Variant ' Indexes of sorted row
1869 Dim lMin1 As Long ' LBound1 of input array
1870 Dim lMax1 As Long ' UBound1 of input array
1871 Dim lMin2 As Long ' LBound2 of input array
1872 Dim lMax2 As Long ' UBound2 of input array
1873 Dim i As Long, j As Long
1875 Const cstSubArgs = "Array_2D, RowIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
1877 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1878 vSort = Array()
1880 Check:
1882 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1883 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1886 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1887 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1888 End If
1890 Try:
1895 ' Extract and sort the RowIndex-th row
1896 vRow = SF_Array.ExtractRow(Array_2D, RowIndex)
1897 If Not SF_Utils._ValidateArray(vRow, "Row #" & CStr(RowIndex), 1, 0) Then GoTo Finally
1900 ' Load output array
1901 ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
1902 For i = lMin1 To lMax1
1903 For j = lMin2 To lMax2
1904 vSort(i, j) = Array_2D(i, vIndexes(j))
1905 Next j
1906 Next i
1908 Finally:
1909 SortColumns = vSort()
1910 SF_Utils._ExitFunction(cstThisSub)
1911 Exit Function
1912 Catch:
1913 GoTo Finally
1914 CatchIndex:
1915 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
1917 GoTo Finally
1918 End Function ' ScriptForge.SF_Array.SortColumns
1920 REM -----------------------------------------------------------------------------
1921 Public Function SortRows(Optional ByRef Array_2D As Variant _
1922 , Optional ByVal ColumnIndex As Variant _
1923 , Optional ByVal SortOrder As Variant _
1924 , Optional ByVal CaseSensitive As Variant _
1925 ) As Variant
1926 ''' Returns a permutation of the rows of a 2D array, sorted on the values of a given column
1927 ''' Args:
1928 ''' Array_2D: the input array
1929 ''' ColumnIndex: the index of the column to sort the rows on
1930 ''' the column must be filled homogeneously by either strings, dates or numbers
1931 ''' Null and Empty values are allowed
1933 ''' CaseSensitive: Default = False
1934 ''' Returns:
1935 ''' the array with permuted Rows, LBounds and UBounds are unchanged
1936 ''' Exceptions:
1937 ''' ARRAYINDEXERROR
1938 ''' Examples:
1943 Dim vSort() As Variant ' Return value
1944 Dim vCol() As Variant ' The column on which to sort the array
1945 Dim vIndexes() As Variant ' Indexes of sorted row
1946 Dim lMin1 As Long ' LBound1 of input array
1947 Dim lMax1 As Long ' UBound1 of input array
1948 Dim lMin2 As Long ' LBound2 of input array
1949 Dim lMax2 As Long ' UBound2 of input array
1950 Dim i As Long, j As Long
1952 Const cstSubArgs = "Array_2D, ColumnIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]"
1954 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1955 vSort = Array()
1957 Check:
1959 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
1960 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1963 If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally
1964 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
1965 End If
1967 Try:
1972 ' Extract and sort the ColumnIndex-th column
1973 vCol = SF_Array.ExtractColumn(Array_2D, ColumnIndex)
1974 If Not SF_Utils._ValidateArray(vCol, "Column #" & CStr(ColumnIndex), 1, 0) Then GoTo Finally
1977 ' Load output array
1978 ReDim vSort(lMin1 To lMax1, lMin2 To lMax2)
1979 For i = lMin1 To lMax1
1980 For j = lMin2 To lMax2
1981 vSort(i, j) = Array_2D(vIndexes(i), j)
1982 Next j
1983 Next i
1985 Finally:
1986 SortRows = vSort()
1987 SF_Utils._ExitFunction(cstThisSub)
1988 Exit Function
1989 Catch:
1990 GoTo Finally
1991 CatchIndex:
1992 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub)
1994 GoTo Finally
1995 End Function ' ScriptForge.SF_Array.SortRows
1997 REM -----------------------------------------------------------------------------
1998 Public Function Transpose(Optional ByRef Array_2D As Variant) As Variant
2000 ''' Args:
2001 ''' Array_2D: the array to transpose
2002 ''' Returns:
2003 ''' The transposed array
2004 ''' Examples:
2009 Dim vTranspose As Variant ' Return value
2010 Dim lIndex As Long ' vTranspose index
2011 Dim lMin1 As Long ' LBound1 of input array
2012 Dim lMax1 As Long ' UBound1 of input array
2013 Dim lMin2 As Long ' LBound2 of input array
2014 Dim lMax2 As Long ' UBound2 of input array
2015 Dim i As Long, j As Long
2019 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2020 vTranspose = Array()
2022 Check:
2023 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2025 End If
2027 Try:
2028 ' Resize the output array
2031 If lMin1 <= lMax1 Then
2032 ReDim vTranspose(lMin2 To lMax2, lMin1 To lMax1)
2033 End If
2035 ' Transpose items
2036 For i = lMin1 To lMax1
2037 For j = lMin2 To lMax2
2038 vTranspose(j, i) = Array_2D(i, j)
2039 Next j
2040 Next i
2042 Finally:
2043 Transpose = vTranspose
2044 SF_Utils._ExitFunction(cstThisSub)
2045 Exit Function
2046 Catch:
2047 GoTo Finally
2048 End Function ' ScriptForge.SF_Array.Transpose
2050 REM -----------------------------------------------------------------------------
2051 Public Function TrimArray(Optional ByRef Array_1D As Variant) As Variant
2053 ''' Strings are trimmed as well
2054 ''' Args:
2055 ''' Array_1D: the array to scan
2056 ''' Return: The trimmed array
2057 ''' Examples:
2058 ''' SF_Array.TrimArray(Array("A","B",Null," D ")) returns ("A","B","D")
2060 Dim vTrimArray As Variant ' Return value
2061 Dim lIndex As Long ' vTrimArray index
2062 Dim lMin As Long ' LBound of input array
2063 Dim lMax As Long ' UBound of input array
2064 Dim vItem As Variant ' Single array item
2065 Dim i As Long
2069 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2070 vTrimArray = Array()
2072 Check:
2073 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2075 End If
2077 Try:
2078 lMin = LBound(Array_1D)
2079 lMax = UBound(Array_1D)
2080 If lMin <= lMax Then
2081 ReDim vTrimArray(lMin To lMax)
2082 End If
2083 lIndex = lMin - 1
2085 ' Load only valid items from Array_1D to vTrimArray
2086 For i = lMin To lMax
2087 vItem = Array_1D(i)
2088 Select Case VarType(vItem)
2089 Case V_EMPTY
2090 Case V_NULL : vItem = Empty
2091 Case V_STRING
2092 vItem = Trim(vItem)
2093 If Len(vItem) = 0 Then vItem = Empty
2094 Case Else
2095 End Select
2096 If Not IsEmpty(vItem) Then
2097 lIndex = lIndex + 1
2098 vTrimArray(lIndex) = vItem
2099 End If
2100 Next i
2102 'Keep valid entries
2103 If lMin <= lIndex Then
2104 ReDim Preserve vTrimArray(lMin To lIndex)
2105 Else
2106 vTrimArray = Array()
2107 End If
2109 Finally:
2110 TrimArray = vTrimArray
2111 SF_Utils._ExitFunction(cstThisSub)
2112 Exit Function
2113 Catch:
2114 GoTo Finally
2115 End Function ' ScriptForge.SF_Array.TrimArray
2117 REM -----------------------------------------------------------------------------
2118 Public Function Union(Optional ByRef Array1_1D As Variant _
2119 , Optional ByRef Array2_1D As Variant _
2120 , Optional ByVal CaseSensitive As Variant _
2121 ) As Variant
2122 ''' Build a set being the Union of the two input arrays, i.e. items are contained in any of both arrays
2123 ''' both input arrays must be filled homogeneously, i.e. all items must be of the same type
2124 ''' Empty and Null items are forbidden
2125 ''' The comparison between strings is case sensitive or not
2126 ''' Args:
2129 ''' CaseSensitive: default = False
2130 ''' Returns: a zero-based array containing unique items stored in any of both input arrays
2131 ''' The output array is sorted in ascending order
2132 ''' Examples:
2133 ''' SF_Array.Union(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B", "C", "Z", "b")
2135 Dim vUnion() As Variant ' Return value
2136 Dim iType As Integer ' VarType of elements in input arrays
2141 Dim lSize As Long ' Number of Union items
2142 Dim i As Long
2146 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2147 vUnion = Array()
2149 Check:
2150 If IsMissing(CaseSensitive) Then CaseSensitive = False
2151 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2153 iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D)))
2154 If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally
2155 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
2156 End If
2158 Try:
2159 lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D)
2160 lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D)
2162 ' If both arrays are empty, do nothing
2165 vUnion = SF_Array.Unique(Array2_1D, CaseSensitive)
2167 vUnion = SF_Array.Unique(Array1_1D, CaseSensitive)
2168 Else
2170 ' Build union of both arrays
2172 lSize = -1
2174 ' Fill vUnion one by one only with items present in any set
2175 For i = lMin1 To lMax1
2176 lSize = lSize + 1
2177 vUnion(lSize) = Array1_1D(i)
2178 Next i
2179 For i = lMin2 To lMax2
2180 lSize = lSize + 1
2181 vUnion(lSize) = Array2_1D(i)
2182 Next i
2184 ' Remove duplicates
2185 vUnion() = SF_Array.Unique(vUnion, CaseSensitive)
2186 End If
2188 Finally:
2189 Union = vUnion()
2190 SF_Utils._ExitFunction(cstThisSub)
2191 Exit Function
2192 Catch:
2193 GoTo Finally
2194 End Function ' ScriptForge.SF_Array.Union
2196 REM -----------------------------------------------------------------------------
2197 Public Function Unique(Optional ByRef Array_1D As Variant _
2198 , Optional ByVal CaseSensitive As Variant _
2199 ) As Variant
2200 ''' Build a set of unique values derived from the input array
2201 ''' the input array must be filled homogeneously, i.e. all items must be of the same type
2202 ''' Empty and Null items are forbidden
2203 ''' The comparison between strings is case sensitive or not
2204 ''' Args:
2205 ''' Array_1D: the input array with potential duplicates
2206 ''' CaseSensitive: default = False
2207 ''' Returns: the array without duplicates with same LBound as input array
2208 ''' The output array is sorted in ascending order
2209 ''' Examples:
2210 ''' Unique(Array("A", "C", "A", "b", "B"), True) returns ("A", "B", "C", "b")
2212 Dim vUnique() As Variant ' Return value
2213 Dim vSorted() As Variant ' The input array after sort
2214 Dim lMin As Long ' LBound of input array
2215 Dim lMax As Long ' UBound of input array
2216 Dim lUnique As Long ' Number of unique items
2217 Dim vIndex As Variant ' Output of _FindItem() method
2218 Dim vItem As Variant ' One single item in the array
2219 Dim i As Long
2223 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2224 vUnique = Array()
2226 Check:
2227 If IsMissing(CaseSensitive) Then CaseSensitive = False
2228 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2230 If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally
2231 End If
2233 Try:
2234 lMin = LBound(Array_1D)
2235 lMax = UBound(Array_1D)
2236 If lMax >= lMin Then
2237 ' First sort the array
2239 ReDim vUnique(lMin To lMax)
2240 lUnique = lMin
2241 ' Fill vUnique one by one ignoring duplicates
2242 For i = lMin To lMax
2243 vItem = vSorted(i)
2244 If i = lMin Then
2245 vUnique(i) = vItem
2246 Else
2248 Else
2249 lUnique = lUnique + 1
2250 vUnique(lUnique) = vItem
2251 End If
2252 End If
2253 Next i
2254 ' Remove unfilled entries
2255 ReDim Preserve vUnique(lMin To lUnique)
2256 End If
2258 Finally:
2259 Unique = vUnique()
2260 SF_Utils._ExitFunction(cstThisSub)
2261 Exit Function
2262 Catch:
2263 GoTo Finally
2264 End Function ' ScriptForge.SF_Array.Unique
2266 REM ============================================================= PRIVATE METHODS
2268 REM -----------------------------------------------------------------------------
2269 Public Function _FindItem(ByRef pvArray_1D As Variant _
2270 , ByVal pvToFind As Variant _
2271 , ByVal pbCaseSensitive As Boolean _
2272 , ByVal psSortOrder As String _
2273 ) As Variant
2274 ''' Check if a 1D array contains the ToFind number, string or date and return its index
2275 ''' The comparison between strings can be done case-sensitively or not
2276 ''' If the array is sorted then a binary search is done
2277 ''' Otherwise the array is scanned from top. Null or Empty items are simply ignored
2278 ''' Args:
2279 ''' pvArray_1D: the array to scan
2280 ''' pvToFind: a number, a date or a string to find
2281 ''' pbCaseSensitive: Only for string comparisons, default = False
2282 ''' psSortOrder: "ASC", "DESC" or "" (= not sorted, default)
2286 ''' if not found: if sorted, index of next item in the array (might be = UBound + 1)
2287 ''' if not sorted, meaningless
2288 ''' Result is unpredictable when array is announced sorted and is in reality not
2289 ''' Called by Contains, IndexOf and InsertSorted. Also called by SF_Dictionary
2291 Dim bContains As Boolean ' True if match found
2292 Dim iToFindType As Integer ' VarType of pvToFind
2293 Dim lTop As Long, lBottom As Long ' Interval in scope of binary search
2294 Dim lIndex As Long ' Index used in search
2295 Dim iCompare As Integer ' Output of _ValCompare function
2296 Dim lLoops As Long ' Count binary searches
2297 Dim lMaxLoops As Long ' Max number of loops during binary search: to avoid infinite loops if array not sorted
2300 bContains = False
2303 Else
2304 ' Search sequentially
2305 If Len(psSortOrder) = 0 Then
2306 For lIndex = LBound(pvArray_1D) To UBound(pvArray_1D)
2307 bContains = ( SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive) = 0 )
2308 If bContains Then Exit For
2309 Next lIndex
2310 Else
2311 ' Binary search
2313 lTop = UBound(pvArray_1D)
2314 lBottom = lBound(pvArray_1D)
2315 Else
2316 lBottom = UBound(pvArray_1D)
2317 lTop = lBound(pvArray_1D)
2318 End If
2319 lLoops = 0
2321 Do
2322 lLoops = lLoops + 1
2323 lIndex = (lTop + lBottom) / 2
2324 iCompare = SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive)
2325 Select Case True
2326 Case iCompare = 0 : bContains = True
2328 lTop = lIndex - 1
2330 lBottom = lIndex - 1
2332 lBottom = lIndex + 1
2334 lTop = lIndex + 1
2335 End Select
2336 Loop Until ( bContains ) Or ( lBottom > lTop And psSortOrder = "ASC" ) Or (lBottom < lTop And psSortOrder = "DESC" ) Or lLoops > lMaxLoops
2337 ' Flag first next non-matching element
2339 End If
2340 End If
2342 ' Build output array
2343 vFound(0) = bContains
2344 vFound(1) = lIndex
2345 _FindItem = vFound
2347 End Function ' ScriptForge.SF_Array._FindItem
2349 REM -----------------------------------------------------------------------------
2350 Private Function _HeapSort(ByRef pvArray As Variant _
2351 , Optional ByVal pbAscending As Boolean _
2352 , Optional ByVal pbCaseSensitive As Boolean _
2353 ) As Variant
2354 ''' Sort an array: items are presumed all strings, all dates or all numeric
2355 ''' Null or Empty are allowed and are considered smaller than other items
2356 ''' https://en.wikipedia.org/wiki/Heapsort
2357 ''' http://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-(sort-array-sorting-arrays)&p=2909250#post2909250
2358 ''' HeapSort preferred to QuickSort because not recursive (this routine returns an array of indexes !!)
2359 ''' Args:
2361 ''' pbAscending: default = True
2362 ''' pbCaseSensitive: default = False
2363 ''' Returns
2364 ''' An array of Longs of same dimensions as the input array listing the indexes of the sorted items
2365 ''' An empty array if the sort failed
2366 ''' Examples:
2369 Dim vIndexes As Variant ' Return value
2370 Dim i As Long
2371 Dim lMin As Long, lMax As Long ' Array bounds
2372 Dim lSwap As Long ' For index swaps
2374 If IsMissing(pbAscending) Then pbAscending = True
2375 If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
2376 vIndexes = Array()
2377 lMin = LBound(pvArray, 1)
2378 lMax = UBound(pvArray, 1)
2380 ' Initialize output array
2381 ReDim vIndexes(lMin To lMax)
2382 For i = lMin To lMax
2383 vIndexes(i) = i
2384 Next i
2386 ' Initial heapify
2388 SF_Array._HeapSort1(pvArray, vIndexes, i, lMin, lMax, pbCaseSensitive)
2389 Next i
2390 ' Next heapify
2392 ' Only indexes as swapped, not the array items themselves
2393 lSwap = vIndexes(i)
2394 vIndexes(i) = vIndexes(lMin)
2395 vIndexes(lMin) = lSwap
2396 SF_Array._HeapSort1(pvArray, vIndexes, lMin, lMin, i - 1, pbCaseSensitive)
2397 Next i
2399 If pbAscending Then _HeapSort = vIndexes() Else _HeapSort = SF_Array.Reverse(vIndexes())
2401 End Function ' ScriptForge.SF_Array._HeapSort
2403 REM -----------------------------------------------------------------------------
2404 Private Sub _HeapSort1(ByRef pvArray As Variant _
2405 , ByRef pvIndexes As Variant _
2406 , ByVal plIndex As Long _
2407 , ByVal plMin As Long _
2408 , ByVal plMax As Long _
2409 , ByVal pbCaseSensitive As Boolean _
2410 )
2411 ''' Sub called by _HeapSort only
2413 Dim lLeaf As Long
2414 Dim lSwap As Long
2416 Do
2417 lLeaf = plIndex + plIndex - (plMin - 1)
2418 Select Case lLeaf
2419 Case Is > plMax: Exit Do
2420 Case Is < plMax
2421 If SF_Array._ValCompare(pvArray(pvIndexes(lLeaf + 1)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then lLeaf = lLeaf + 1
2422 End Select
2423 If SF_Array._ValCompare(pvArray(pvIndexes(plIndex)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then Exit Do
2424 ' Only indexes as swapped, not the array items themselves
2425 lSwap = pvIndexes(plIndex)
2426 pvIndexes(plIndex) = pvIndexes(lLeaf)
2427 pvIndexes(lLeaf) = lSwap
2428 plIndex = lLeaf
2429 Loop
2431 End Sub ' ScriptForge.SF_Array._HeapSort1
2433 REM -----------------------------------------------------------------------------
2434 Private Function _Repr(ByRef pvArray As Variant) As String
2435 ''' Convert array to a readable string, typically for debugging purposes (DebugPrint ...)
2436 ''' Args:
2437 ''' pvArray: the array to convert, individual items may be of any type, including arrays
2438 ''' Return:
2442 Dim iDims As Integer ' Number of dimensions of the array
2443 Dim sArray As String ' Return value
2444 Dim i As Long
2450 _Repr = ""
2451 iDims = SF_Array.CountDims(pvArray)
2453 Select Case iDims
2455 Case 0 : sArray = cstArrayEmpty
2456 Case Else
2457 sArray = cstArray
2458 For i = 1 To iDims
2459 sArray = sArray & Iif(i = 1, " (", ", ") & CStr(LBound(pvArray, i)) & ":" & CStr(UBound(pvArray, i))
2460 Next i
2463 If iDims = 1 Then
2465 For i = LBound(pvArray) To UBound(pvArray)
2466 sArray = sArray & SF_Utils._Repr(pvArray(i), cstMaxLength) & cstSeparator ' Recursive call
2467 Next i
2468 sArray = Left(sArray, Len(sArray) - Len(cstSeparator)) ' Suppress last comma
2470 End If
2471 End Select
2473 _Repr = sArray
2475 End Function ' ScriptForge.SF_Array._Repr
2477 REM -----------------------------------------------------------------------------
2478 Public Function _StaticType(ByRef pvArray As Variant) As Integer
2479 ''' If array is static, return its type
2480 ''' Args:
2481 ''' pvArray: array to examine
2482 ''' Return:
2484 ''' All numeric types are aggregated into V_NUMERIC
2486 Dim iArrayType As Integer ' VarType of array
2487 Dim iType As Integer ' VarType of items
2489 iArrayType = VarType(pvArray)
2490 iType = iArrayType - V_ARRAY
2491 Select Case iType
2492 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL, V_BOOLEAN
2493 _StaticType = V_NUMERIC
2494 Case V_STRING, V_DATE
2495 _StaticType = iType
2496 Case Else
2497 _StaticType = -1
2498 End Select
2500 End Function ' ScriptForge.SF_Utils._StaticType
2502 REM -----------------------------------------------------------------------------
2503 Private Function _ValCompare(ByVal pvValue1 As Variant _
2504 , pvValue2 As Variant _
2505 , Optional ByVal pbCaseSensitive As Boolean _
2506 ) As Integer
2508 ''' Args:
2509 ''' pvValue1 and pvValue2: values to compare. pvValues must be String, Number, Date, Empty or Null
2511 ''' pbCaseSensitive: ignored when not String comparison
2517 Dim iCompare As Integer, iVarType1 As Integer, iVarType2 As Integer
2519 If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False
2520 iVarType1 = SF_Utils._VarTypeExt(pvValue1)
2521 iVarType2 = SF_Utils._VarTypeExt(pvValue2)
2523 iCompare = -2
2525 ElseIf iVarType2 = V_OBJECT Or iVarType2 = V_BYTE Or iVarType2 >= V_ARRAY Then ' Nonsense
2526 ElseIf iVarType1 = V_STRING And iVarType2 = V_STRING Then
2528 ElseIf iVarType1 = V_NULL Or iVarType1 = V_EMPTY Or iVarType2 = V_NULL Or iVarType2 = V_EMPTY Then
2529 Select Case True
2530 Case pvValue1 = pvValue2 : iCompare = 0
2531 Case iVarType1 = V_NULL And iVarType2 = V_EMPTY : iCompare = +1
2532 Case iVarType1 = V_EMPTY And iVarType2 = V_NULL : iCompare = -1
2533 Case iVarType1 = V_NULL Or iVarType1 = V_EMPTY : iCompare = -1
2534 Case iVarType2 = V_NULL Or iVarType2 = V_EMPTY : iCompare = +1
2535 End Select
2536 ElseIf iVarType1 = iVarType2 Then
2537 Select Case True
2539 Case pvValue1 = pvValue2 : iCompare = 0
2541 End Select
2542 End If
2544 _ValCompare = iCompare
2546 End Function ' ScriptForge.SF_Array._ValCompare
2548 REM ================================================= END OF SCRIPTFORGE.SF_ARRAY
2549 </script:module>