Attribute VB_Name = "stdArray" '@TODO: '* Implement Exceptions throughout all Array functions. '* Fully implement pInitialised where necessary. '* Build Methods Slice; Splice; Sort '* Add methods from ruby '* Documentation of methods #If VBA6 Then Private Declare PtrSafe Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long) #Else Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) #End If Private Enum SortDirection Ascending = 1 Descending = 2 End Enum Private Type SortStruct value As Variant sortValue As Variant End Type Private pArr() As Variant Private pProxyLength As Long Private pLength As Long Private pChunking As Long Private pInitialised As Boolean Public Event BeforeArrLet(ByRef arr As stdArray, ByRef arr As Variant) Public Event AfterArrLet(ByRef arr As stdArray, ByRef arr As Variant) Public Event BeforeAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean) Public Event AfterAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant) Public Event BeforeRemove(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean) Public Event AfterRemove(ByRef arr As stdArray, ByVal iIndex As Long) Public Event AfterClone(ByRef Clone As stdArray) Public Event AfterCreate(ByRef arr As stdArray) 'Create a stdArray object from params '@param {paramarray variant()} The items of the array '@returns {stdArray} A stdArray from the parameters. Public Function Create(ParamArray params() As Variant) As stdArray Set Create = New stdArray Dim i As Long Dim lb As Long: lb = LBound(params) Dim ub As Long: ub = UBound(params) Call Create.Init(ub - lb + 1, 10) For i = lb To ub Call Create.Push(params(i)) Next 'Raise AfterCreate event RaiseEvent AfterCreate(Create) End Function 'Create a stdArray object from params '@param {Long} The length of the initial private array created '@param {Long} The number of items the private array is increased by when required. '@param {paramarray variant()} The items of the array '@returns {stdArray} A stdArray from the parameters. Public Function CreateWithOptions(ByVal iInitialLength As Long, ByVal iChunking As Long, ParamArray params() As Variant) As stdArray Set CreateWithOptions = New stdArray Dim i As Long Dim lb As Long: lb = LBound(params) Dim ub As Long: ub = UBound(params) Call CreateWithOptions.Init(iInitialLength, iChunking) For i = lb To ub Call CreateWithOptions.Push(params(i)) Next 'Raise AfterCreate event RaiseEvent AfterCreate(Create) End Function 'Create a stdArray object from a VBA array '@param {variant()} Variant array to create a `stdArray` object from. '@returns {stdArray} Returns `stdArray` of variants. Public Function CreateFromArray(ByVal arr As Variant) As stdArray Set CreateFromArray = New stdArray Dim i As Long Dim lb As Long: lb = LBound(arr) Dim ub As Long: ub = UBound(arr) Call CreateFromArray.Init(ub - lb + 1, 10) For i = lb To ub Call CreateFromArray.Push(arr(i)) Next 'Raise AfterCreate event RaiseEvent AfterCreate(Create) End Function 'Create an array by splitting a string '@param {string} Haystack to split '@param {string?=","} Delimiter '@returns {stdArray} A list of strings Public Function CreateFromString(ByVal sHaystack As String, Optional ByVal sDelimiter As String = ",") As stdArray Set CreateFromString = CreateFromArray(Split(sHaystack, sDelimiter)) End Function 'Initialise array '@param {Long} The length of the initial private array created '@param {Long} The number of items the private array is increased by when required. Friend Sub Init(ByVal iInitialLength As Long, ByVal iChunking As Long) If iChunking > iInitialLength Then iInitialLength = iChunking If Not pInitialised Then pProxyLength = iInitialLength ReDim pArr(1 To iInitialLength) As Variant pChunking = iChunking pInitialised = True End If End Sub 'Obtain a collection from the data contained within the array. Primarily used for NewEnum() method. '@returns {Collection} Collection from Array Public Function AsCollection() As collection Set AsCollection = New collection Dim i As Long For i = 1 To Length() AsCollection.Add pArr(i) Next End Function 'For-each compatibility '@protected '@returns {IEnumVARIANT} An enumerator with methods enumNext, enumRefresh etc. '@usage `For each obj in myEnum: ... : next` '@TODO: Use custom IEnumVARIANT instead of casting to Collection Public Property Get NewEnum() As IUnknown Static oEnumCol As collection: If oEnumCol Is Nothing Then Set oEnumCol = AsCollection() Set NewEnum = oEnumCol.[_NewEnum] End Property 'Obtain the length of the array Public Property Get Length() As Long Length = pLength End Property 'Obtain the length of the private array which stores the data of this array class Public Property Get zProxyLength() As Long zProxyLength = pProxyLength End Property 'Resize the array to a length '@param {Long} The length of the desired array Public Sub Resize(ByVal iLength As Long) pLength = iLength End Sub 'Rechunk the private array to the length / number of items. Public Sub Rechunk() Dim fNumChunks As Double, iNumChunks As Long fNumChunks = pLength / pChunking iNumChunks = CLng(fNumChunks) If fNumChunks > iNumChunks Then iNumChunks = iNumChunks + 1 ReDim Preserve pArr(1 To iNumChunks * pChunking) As Variant End Sub 'Sort the array '@param {stdICallable<(variant)=>variant>} A mapping function which should map whatever the input is to whatever variant the array should be sorted on. '@param {stdICallable<(variant,variant)=>boolean>} Comparrison function which consumes 2 variants and generates a boolean. See implementation of `Sort_QuickSort` for details. '@param {long} Currently only 1 algorithm: 0 - Quicksort '@param {boolean} Sort the array in place. Sorting in-place is prefferred if possible as it is much more performant. '@returns {stdArray} Public Function Sort(Optional ByVal cbSortBy As stdICallable = Nothing, Optional ByVal cbComparrason As stdICallable = Nothing, Optional ByVal iAlgorithm As Long = 0, Optional ByVal bSortInPlace As Boolean = False) As stdArray If Not bSortInPlace Then Set Sort = Clone().Sort(cbSortBy, cbComparrason, iAlgorithm, True) Else If Length() = 0 Then Set Sort = Me Exit Function End If Dim arr() As SortStruct ReDim arr(1 To Length()) As SortStruct Dim i As Long 'Copy array to sort structures For i = 1 To Length() Call CopyVariant(arr(i).value, pArr(i)) If cbSortBy Is Nothing Then Call CopyVariant(arr(i).sortValue, pArr(i)) Else Call CopyVariant(arr(i).sortValue, cbSortBy.Run(pArr(i))) End If Next 'Call sort algorithm Select Case iAlgorithm Case 0 'QuickSort Call Sort_QuickSort(arr, cbComparrason) Case Else stdError.Raise "Invalid sorting algorithm specified" End Select 'Copy sort structures to array For i = 1 To Length() Call CopyVariant(pArr(i), arr(i).value) Next 'Return array Set Sort = Me End If End Function 'QuickSort3 ' Src: https://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-%28sort-array-sorting-arrays%29 ' Omit plngLeft & plngRight; they are used internally during recursion Private Sub Sort_QuickSort(ByRef pvarArray() As SortStruct, Optional cbComparrison As stdICallable = Nothing, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long) Dim lngFirst As Long Dim lngLast As Long Dim varMid As SortStruct Dim varSwap As SortStruct If plngRight = 0 Then plngLeft = 1 plngRight = Length() End If lngFirst = plngLeft lngLast = plngRight varMid = pvarArray((plngLeft + plngRight) \ 2) Do If cbComparrison Is Nothing Then Do While pvarArray(lngFirst).sortValue < varMid.sortValue And lngFirst < plngRight lngFirst = lngFirst + 1 Loop Do While varMid.sortValue < pvarArray(lngLast).sortValue And lngLast > plngLeft lngLast = lngLast - 1 Loop Else Do While cbComparrison.Run(pvarArray(lngFirst).sortValue, varMid.sortValue) And lngFirst < plngRight lngFirst = lngFirst + 1 Loop Do While cbComparrison.Run(varMid.sortValue, pvarArray(lngLast).sortValue) And lngLast > plngLeft lngLast = lngLast - 1 Loop End If If lngFirst <= lngLast Then varSwap = pvarArray(lngFirst) pvarArray(lngFirst) = pvarArray(lngLast) pvarArray(lngLast) = varSwap lngFirst = lngFirst + 1 lngLast = lngLast - 1 End If Loop Until lngFirst > lngLast If plngLeft < lngLast Then Sort_QuickSort pvarArray, cbComparrison, plngLeft, lngLast If lngFirst < plngRight Then Sort_QuickSort pvarArray, cbComparrison, lngFirst, plngRight End Sub 'Obtain the array as a regular VBA array Public Property Get arr() As Variant If pLength = 0 Then arr = Array() Else Dim vRet() As Variant ReDim vRet(1 To pLength) As Variant For i = 1 To pLength Call CopyVariant(vRet(i), pArr(i)) Next arr = vRet End If End Property Public Property Let arr(v As Variant) RaiseEvent BeforeArrLet(Me, v) Dim lb As Long: lb = LBound(v) Dim ub As Long: ub = UBound(v) Dim cnt As Long: cnt = ub - lb + 1 ReDim pArr(1 To (Int(cnt / pChunking) + 1) * pChunking) As Variant For i = lb To ub Call Push(pArr(i)) Next RaiseEvent AfterArrLet(Me, v) End Property 'Add an element to the end of the array '@param {variant} The element to add to the end of the array. '@returns {stdArray} me 'TODO: Add multiple elements with push Public Function Push(ByVal el As Variant) As stdArray If pInitialised Then 'Before Add event Dim bCancel As Boolean RaiseEvent BeforeAdd(Me, pLength + 1, el, bCancel) If bCancel Then Exit Function If pLength = pProxyLength Then pProxyLength = pProxyLength + pChunking ReDim Preserve pArr(1 To pProxyLength) As Variant End If pLength = pLength + 1 CopyVariant pArr(pLength), el 'After add event RaiseEvent AfterAdd(Me, pLength, pArr(pLength)) Set Push = Me Else 'Error End If End Function 'Remove an element from the end of the array '@returns {variant} The element removed from the array Public Function Pop() As Variant If pInitialised Then If pLength > 0 Then 'Raise BeforeRemove event and optionally cancel Dim bCancel As Boolean RaiseEvent BeforeRemove(Me, pLength, pArr(pLength), bCancel) If bCancel Then Exit Function CopyVariant Pop, pArr(pLength) pLength = pLength - 1 'Raise AfterRemove event RaiseEvent AfterRemove(Me, pLength) Else Pop = Empty End If Else 'Error End If End Function 'Remove the ith element from the array '@param {Long} Index of the element to remove '@returns {Variant} The element removed Public Function Remove(ByVal index As Long) As Variant 'Ensure initialised If pInitialised Then 'Ensure length > 0 If pLength > 0 Then 'Ensure index < length If index <= pLength Then 'Raise BeforeRemove event and optionally cancel Dim bCancel As Boolean RaiseEvent BeforeRemove(Me, index, pArr(index), bCancel) If bCancel Then Exit Function 'Copy party we are removing to return variable CopyVariant Remove, pArr(index) 'Loop through array from removal, set i-1th element to ith element Dim i As Long For i = index + 1 To pLength pArr(i - 1) = pArr(i) Next 'Set last element length and subtract total length by 1 pArr(pLength) = Empty pLength = pLength - 1 'Raise after remove event RaiseEvent AfterRemove(Me, index) Else 'Error End If Else 'Error End If Else 'Error End If End Function 'Remove and return element from the start of the array '@returns {variant} Element removed Public Function Shift() As Variant 'Would be good to use CopyMemory here CopyVariant Shift, pArr(1) Dim i As Long For i = 1 To pLength - 1 pArr(i) = pArr(i + 1) Next pLength = pLength - 1 End Function 'Insert an element onto the start of the array '@param {Variant} Value to append to the start of the array '@returns {stdArray} me Public Function Unshift(val As Variant) As stdArray 'Would be good to use CopyMemory here 'Before Add event Dim bCancel As Boolean RaiseEvent BeforeAdd(Me, 1, val, bCancel) If bCancel Then Exit Function 'Ensure array is big enough and increase pLength If pLength = pProxyLength Then pProxyLength = pProxyLength + pChunking ReDim Preserve pArr(1 To pProxyLength) As Variant End If pLength = pLength + 1 'Unshift For i = pLength - 1 To 1 Step -1 pArr(i + 1) = pArr(i) Next pArr(1) = val 'After Add event RaiseEvent AfterAdd(Me, 1, val) Set Unshift = Me End Function 'TODO: 'Public Function Slice() As stdArray ' 'End Function 'TODO: 'Public Function Splice() As stdArray ' 'End Function 'Creates a new instance of the same array '@returns {stdArray} Public Function Clone() As stdArray If pInitialised Then If pInitialised Then 'Similar to CreateFromArray() but passing length through also: Set Clone = New stdArray Call Clone.Init(pLength, 10) Dim i As Long For i = 1 To pLength Call Clone.Push(pArr(i)) Next Else 'Error End If RaiseEvent AfterClone(Clone) Else 'Error End If End Function 'Returns a new array with all elements in reverse order '@returns {stdArray} Public Function Reverse() As stdArray 'TODO: Need to find a better more low level approach to creating arrays from existing arrays/preventing redim for methods like this Dim ret As stdArray Set ret = stdArray.Create() For i = pLength To 1 Step -1 Call ret.Push(pArr(i)) Next Set Reverse = ret End Function 'Concatenate an existing array of elements onto the end of this array '@param {stdArray} Array whose elements we wish to append to the end of this array '@returns {stdArray} New composite array. Public Function Concat(ByVal arr As stdArray) As stdArray Dim x As stdArray Set x = Clone() If Not arr Is Nothing Then Dim i As Long For i = 1 To arr.Length Call x.Push(arr.item(i)) Next End If Set Concat = x End Function 'Join each of the elements of this array together as a string '@param {string} Delimiter to insert between strings Public Function Join(Optional ByVal delimeter As String = ",") As String If pInitialised Then If pLength > 0 Then Dim sOutput As String sOutput = pArr(1) Dim i As Long For i = 2 To pLength sOutput = sOutput & delimeter & pArr(i) Next Join = sOutput Else Join = "" End If Else 'Error End If End Function 'Get/Let/Set item '@param {long} The location to get/set the item Public Property Get item(ByVal i As Long) As Variant 'item(1) = 1st element 'item(2) = 2nd element 'etc. CopyVariant item, pArr(i) End Property Public Property Set item(ByVal i As Long, ByVal item As Object) Set pArr(i) = item End Property Public Property Let item(ByVal i As Long, ByVal item As Variant) pArr(i) = item End Property 'Copy a variant into the array's ith element. This saves from having to test the item and call the correct `set` keyword '@param {Long} The index at which the item's data should be set '@param {ByRef Variant} Item to set at the index Public Sub PutItem(ByVal i As Long, ByRef item As Variant) CopyVariant pArr(i), item End Sub 'Obtain the index of an element '@param {Variant} Element to find '@param {Ingeger?=1} Location to start search for element. '@returns {long} Index of element Public Function indexOf(ByVal el As Variant, Optional ByVal start As Long = 1) As Long Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean 'Is element an object? elIsObj = isObject(el) 'Loop over contents starting from start For i = start To pLength 'Get item data CopyVariant item, pArr(i) 'Is item an object? itemIsObj = isObject(item) 'If both item and el are objects (must be the same type in order to be the same data) If itemIsObj And elIsObj Then If item Is el Then 'check items equal indexOf = i 'return item index Exit Function End If 'If both item and el are not objects (must be the same type in order to be the same data) ElseIf Not itemIsObj And Not elIsObj Then If item = el Then 'check items equal indexOf = i 'return item index Exit Function End If End If Next 'Return -1 i.e. no match found indexOf = -1 End Function 'Obtain the last index of an element '@param {Variant} Element to find '@returns {long} Last index of element Public Function lastIndexOf(ByVal el As Variant) Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean 'Is element an object? elIsObj = isObject(el) 'Loop over contents starting from start For i = pLength To 1 Step -1 'Get item data CopyVariant item, pArr(i) 'Is item an object? itemIsObj = isObject(item) 'If both item and el are objects (must be the same type in order to be the same data) If itemIsObj And elIsObj Then If item Is el Then 'check items equal lastIndexOf = i 'return item index Exit Function End If 'If both item and el are not objects (must be the same type in order to be the same data) ElseIf Not itemIsObj And Not elIsObj Then If item = el Then 'check items equal lastIndexOf = i 'return item index Exit Function End If End If Next 'Return -1 i.e. no match found lastIndexOf = -1 End Function 'Returns true if the array contains an item '@param {Variant} Item to find '@param {long?=1} Index to start search for item at. (Internally uses indexOf()) Public Function includes(ByVal el As Variant, Optional ByVal startFrom As Long = 1) As Boolean includes = indexOf(el, startFrom) >= startFrom End Function 'Iterative Functions (All require stdICallable): 'Example: if incidents.IsEvery(cbValid) then ... Public Function IsEvery(ByVal cb As stdICallable) As Boolean If pInitialised Then Dim i As Long For i = 1 To pLength Dim bFlag As Boolean bFlag = cb.Run(pArr(i)) If Not bFlag Then IsEvery = False Exit Function End If Next IsEvery = True Else 'Error End If End Function Public Function IsSome(ByVal cb As stdICallable) As Boolean If pInitialised Then Dim i As Long For i = 1 To pLength Dim bFlag As Boolean bFlag = cb.Run(pArr(i)) If bFlag Then IsSome = True Exit Function End If Next IsSome = False Else 'Error End If End Function Public Sub ForEach(ByVal cb As stdICallable) If pInitialised Then Dim i As Long For i = 1 To pLength Call cb.Run(pArr(i)) Next Else 'Error End If End Sub Public Function Map(ByVal cb As stdICallable) As stdArray If pInitialised Then Dim pMap As stdArray Set pMap = Clone() Dim i As Long For i = 1 To pLength 'BUGFIX: Sometimes required, not sure when Dim v As Variant CopyVariant v, item(i) 'Call callback Call pMap.PutItem(i, cb.Run(v)) Next Set Map = pMap Else 'Error End If End Function 'OPTIMISE: Needs optimisation. Currently very sub-optimal Public Function Unique(Optional ByVal cb As stdICallable = Nothing) As stdArray Dim ret As stdArray: Set ret = stdArray.CreateWithOptions(pLength, pChunking) Dim retL As stdArray: Set retL = CreateWithOptions(pLength, pChunking) 'Collect keys Dim vKeys As stdArray If cb Is Nothing Then Set vKeys = Clone() Else Set vKeys = Map(cb) End If 'Unique by key For i = 1 To pLength If Not retL.includes(vKeys.item(i)) Then Call retL.Push(vKeys.item(i)) Call ret.Push(pArr(i)) End If Next 'Return data Set Unique = ret End Function Public Function reduce(ByVal cb As stdICallable, Optional ByVal initialValue As Variant) As Variant Dim iStart As Long If pInitialised Then If pLength > 0 Then If IsMissing(initialValue) Then Call CopyVariant(reduce, pArr(1)) iStart = 2 Else Call CopyVariant(reduce, initialValue) iStart = 1 End If Else If IsMissing(initialValue) Then reduce = Empty Else Call CopyVariant(reduce, initialValue) End If Exit Function End If Dim i As Long For i = iStart To pLength 'BUGFIX: Sometimes required, not sure when Dim el As Variant CopyVariant el, pArr(i) 'Reduce CopyVariant reduce, cb.Run(reduce, el) Next Else 'Error End If End Function Public Function Filter(ByVal cb As stdICallable) As stdArray Dim ret As stdArray Set ret = stdArray.CreateWithOptions(pLength, pChunking) Set Filter = ret 'If initialised... If pInitialised Then Dim i As Long, v As Variant 'Loop over array For i = 1 To pLength 'If callback succeeds, push retvar If cb.Run(pArr(i)) Then Call ret.Push(pArr(i)) End If Next i Else 'error End If End Function Public Function count(Optional ByVal cb As stdICallable = Nothing) As Long If cb Is Nothing Then count = Length Else Dim i As Long, lCount As Long lCount = 0 For i = 1 To pLength If cb.Run(pArr(i)) Then lCount = lCount + 1 End If Next i count = lCount End If End Function Public Function groupBy(ByVal cb As stdICallable) As Object 'Array to store result in Dim result As Object Set result = CreateObject("Scripting.Dictionary") 'Loop over items Dim i As Long For i = 1 To pLength 'Get grouping key Dim key As Variant key = cb.Run(pArr(i)) 'If key is not set then set it If Not result.Exists(key) Then Set result(key) = stdArray.Create() 'Push item to key result(key).Push pArr(i) Next 'Return result Set groupBy = result End Function Public Function Max(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant Dim vRet, vMaxValue, v vMaxValue = startingValue: vRet = startingValue For i = 1 To pLength Call CopyVariant(v, pArr(i)) 'Get value to test Dim vtValue As Variant If cb Is Nothing Then Call CopyVariant(vtValue, v) Else Call CopyVariant(vtValue, cb.Run(v)) End If 'Compare values and return If IsEmpty(vRet) Then Call CopyVariant(vRet, v) Call CopyVariant(vMaxValue, vtValue) ElseIf vMaxValue < vtValue Then Call CopyVariant(vRet, v) Call CopyVariant(vMaxValue, vtValue) End If Next Call CopyVariant(Max, vRet) End Function Public Function Min(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant Dim vRet, vMinValue, v vMinValue = startingValue: vRet = startingValue For i = 1 To pLength Call CopyVariant(v, pArr(i)) 'Get value to test Dim vtValue As Variant If cb Is Nothing Then Call CopyVariant(vtValue, v) Else Call CopyVariant(vtValue, cb.Run(v)) End If 'Compare values and return If IsEmpty(vRet) Then Call CopyVariant(vRet, v) Call CopyVariant(vMinValue, vtValue) ElseIf vMinValue > vtValue Then Call CopyVariant(vRet, v) Call CopyVariant(vMinValue, vtValue) End If Next Call CopyVariant(Min, vRet) End Function 'Copies one variant to a destination '@param {ByRef Variant} dest Destination to copy variant to '@param {Variant} value Source to copy variant from. '@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant) If isObject(value) Then Set dest = value Else dest = value End If End Sub