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