Option ExplicitPrivate m_elements() As VariantPrivate m_size As LongPrivate m_capacity As LongPrivate m_dic As DictionaryPrivate Sub Class_Initialize() ReDim m_elements(9) m_size = 0 m_capacity = 10 Set m_dic = New DictionaryEnd SubPublic Property Get Capacity() As Long 'all capacity in the array, including unused space Capacity = UBound(m_elements) + 1End PropertyPublic Property Let Capacity(ByVal TotalCapacity As Long) ReDim Preserve m_elements(TotalCapacity - 1) m_capacity = TotalCapacityEnd PropertyPublic Function Length() As Long'includes only used elements in the array Length = m_sizeEnd FunctionPrivate Sub trimToSize() 'If capacity is large and length < 50% of capacity, 'trim total capacity to: (number of used elements * 1.5) If m_capacity > 99 Then If (m_size < (m_capacity / 2)) Then Dim newUBound As Long newUBound = Conversion.CLng(m_size * 1.5) If newUBound < 9 Then 'need at least 10 els newUBound = 9 End If ReDim Preserve m_elements(newUBound) m_capacity = newUBound + 1 End If End IfEnd SubPrivate Sub ensureCapacity(ByVal minCapacity As Long) If m_capacity < minCapacity Then Dim newUBound As Long newUBound = Conversion.CLng(m_capacity * 1.5) ReDim Preserve m_elements(newUBound) m_capacity = newUBound + 1 End IfEnd SubPublic Function isEmpty() As Boolean isEmpty = (m_size = 0)End FunctionPublic Sub Add(Item As Variant, Optional Key As String = "", Optional ByVal Before As Long = -1)'Inserts the specified element at the specified position in this'list. Shifts the element currently at that position (if any) and'any subsequent elements to the right (adds one to their indices). Call ensureCapacity(m_size + 1) 'shift everything to the right of Before by 1 If (Before > -1) Then checkIndex (Before) Dim temp() As Variant ReDim temp(m_size) Call arrayCopy(m_elements(), Before, temp(), 0, m_size - Before) Call arrayCopy(temp(), 0, m_elements(), Before + 1, m_size - Before) If Not IsObject(Item) Then m_elements(Before) = Item Else Set m_elements(Before) = Item End If If Key <> "" Then If m_dic.Exists(Key) Then Call Err.Raise(Key, Description:="The Key can not allowed repeat") m_dic.Add Key, m_elements(Before) End If Else ' no "Before" param If Not IsObject(Item) Then m_elements(m_size) = Item Else Set m_elements(m_size) = Item End If If Key <> "" Then If m_dic.Exists(Key) Then Call Err.Raise(Key, Description:="The Key can not allowed repeat") m_dic.Add Key, Item End If End If m_size = m_size + 1End SubSub removeAt(ByVal index As Long) checkIndex (index) If index < m_size - 1 Then Dim i As Integer For i = index To m_size - 1 If Not IsObject(m_elements(i + 1)) Then m_elements(i) = m_elements(i + 1) Else Set m_elements(i) = m_elements(i + 1) End If Next i m_elements(m_size - 1) = Empty ElseIf index = m_size - 1 Then m_elements(m_size - 1) = Empty End If m_size = m_size - 1 Call trimToSizeEnd SubPublic Property Get ItemByKey(ByVal Key As String) As Variant If m_dic.Exists(Key) Then If IsObject(m_dic(Key)) Then Set ItemByKey = m_dic(Key) Exit Property Else ItemByKey = m_dic(Key) End If Else Call Err.Raise(Key, Description:="The Key can not find") End IfEnd PropertyPublic Property Get ItemByIndex(ByVal index As Long) As Variant If IsObject(m_elements(index - 1)) Then Set ItemByIndex = m_elements(index - 1) Exit Property Else ItemByIndex = m_elements(index - 1) End IfEnd PropertyPublic Property Let ItemByIndex(ByVal index As Long, ByVal value As Variant) checkIndex (index - 1) If IsObject(value) Then Set m_elements(index - 1) = value Else m_elements(index - 1) = value End IfEnd PropertyPublic Sub Remove(ByVal objElement As Variant) 'Remove the first occurrence of the given objElement Dim i As Long For i = 0 To m_size - 1 If (m_elements(i) = objElement) Then Call Me.removeAt(i) Exit For End If Next iEnd SubPublic Sub RemoveAll(ByVal objElement As Variant) 'Remove all occurrences of objElement Dim changes As Long changes = 0 Dim i As Long For i = 0 To m_size - 1 If (m_elements(i - changes) = objElement) Then Call Me.removeAt(i - changes) ' will decrement m_size changes = changes + 1 End If Next i Call trimToSizeEnd SubPublic Sub RemoveRange(ByVal StartingIndex As Long, ByVal EndingIndex As Long)'startindex= first element to remove index, endingindex=final element to remove'TODO: what if startindex > endindex? checkIndex (StartingIndex) checkIndex (EndingIndex) Dim oldm_size As Long oldm_size = m_size 'get all the elements to the right of the range (if there are any elements to the right) If EndingIndex < m_size - 1 Then Dim temp() As Variant temp = Me.Items(EndingIndex + 1, m_size - 1) Call arrayCopy(temp, 0, m_elements, StartingIndex, UBound(temp) + 1) End If m_size = m_size - (EndingIndex - StartingIndex + 1) Dim i As Long For i = m_size To oldm_size - 1 m_elements(i) = Empty Next iEnd SubPublic Function Contains(ByRef Element As Variant) As Boolean Dim result As Boolean result = False Dim i As Long Dim e As Variant For Each e In m_elements If IsObject(Element) Then If e Is Element Then result = True Exit For End If Else If e = Element Then result = True Exit For End If End If i = i + 1 If i = m_size Then Exit For Next e Contains = resultEnd FunctionPublic Function indexOf(ByVal Element As Variant) As Long'Searches for the specified Object and returns the zero-based index of'the first occurrence within the entire ArrayList.'Returns -1 if the Element was not found Dim result As Long result = -1 Dim index As Long index = 0 Dim e As Variant For Each e In m_elements If e = Element Then result = index Exit For End If index = index + 1 Next e indexOf = resultEnd FunctionPublic Function LastIndexOf(ByVal Element As Variant) As Long'Searches for the specified Object and returns the'zero-based index of the last occurrence within the entire ArrayList.'Returns -1 if not found Dim result As Long result = -1 Dim i As Long For i = m_size - 1 To 0 Step -1 If m_elements(i) = Element Then result = i Exit For End If Next i LastIndexOf = resultEnd FunctionPublic Sub Clear() ReDim m_elements(9) m_capacity = 10 m_size = 0End SubPrivate Sub checkIndex(ByVal index As Long) If (index >= m_size) Or (index < 0) Then Call Err.Raise(index, Description:="The index specified is out of bounds") End IfEnd SubPublic Sub Swap(ByVal Index1 As Long, ByVal Index2 As Long) Dim temp As Variant checkIndex (Index1) checkIndex (Index2) If Not IsObject(m_elements(Index2)) Then temp = m_elements(Index2) Else: Set temp = m_elements(Index2) End If If Not IsObject(m_elements(Index1)) Then m_elements(Index2) = m_elements(Index1) Else Set m_elements(Index2) = m_elements(Index1) End If If Not IsObject(temp) Then m_elements(Index1) = temp Else Set m_elements(Index1) = temp End IfEnd SubPublic Sub Reverse() If m_size > 1 Then Dim hiIndex As Long hiIndex = m_size - 1 Dim loIndex As Long loIndex = 0 Do While (hiIndex > loIndex) Call Swap(loIndex, hiIndex) hiIndex = hiIndex - 1 loIndex = loIndex + 1 Loop End IfEnd SubPublic Sub Shuffle() 'uses Fisher-Yates algo Dim i As Long Dim randomNbr As Long For i = m_size - 1 To 1 Step -1 Randomize 'random integer with 0 <= rndnbr <= i, uniformly distributed randomNbr = Int((i + 1) * Rnd) Call Swap(randomNbr, i) Next iEnd SubPublic Function GetDistinctValues() As ArrayList Dim distinctVals As New ArrayList Dim e As Variant For Each e In m_elements If Not distinctVals.Contains(e) Then distinctVals.Add e End If Next e Set GetDistinctValues = distinctValsEnd FunctionPublic Function GetRange(ByVal StartingIndex As Long, ByVal TotalElementsToGet As Long) _As ArrayList'Returns a subset of the elements in this ArrayList.'Index: The 0-based array index at which the range starts.'Count: The number of elements in the range to get. Dim newAL As ArrayList Set newAL = New ArrayList If TotalElementsToGet > 0 Then Dim i As Long If TotalElementsToGet > 9 Then newAL.Capacity = TotalElementsToGet Else: newAL.Capacity = 10 End If For i = StartingIndex To (StartingIndex + TotalElementsToGet - 1) newAL.Add m_elements(i) Next i End If Set GetRange = newALEnd FunctionPublic Sub arrayCopy(array1() As Variant, ByVal startingIndex1 As Long, array2() As Variant, _ startingIndex2 As Long, ByVal TotalElements As Long) On Error Resume Next 'copies from arr1, starting at stin1, to arr2, starting at stin2, TotalElements. 'both arrays must be declared using syntax: dim array1() as or redim array1( ) 'ensure arr2 has at least TE els If UBound(array2) < TotalElements - 1 Then ReDim Preserve array2(TotalElements - 1) End If Dim i As Long Dim j As Long j = startingIndex2 For i = startingIndex1 To startingIndex1 + TotalElements - 1 If Not IsObject(array1(i)) Then array2(j) = array1(i) Else: Set array2(j) = array1(i) End If j = j + 1 Next iEnd SubPublic Sub Sort() 'use quicksort algo If Me.ContainsObjects() Then MsgBox "This VBArrayList contains at least 1 object. Quicksort only works on alphanumeric values." Exit Sub Else Call QuickSort End IfEnd SubPrivate Sub QuickSort(Optional intLeft As Long = -2, _ Optional intRight As Long = -2) Dim i As Long Dim j As Long Dim varTestVal As Variant Dim intMid As Long If intLeft = -2 Then intLeft = 0 If intRight = -2 Then intRight = m_size - 1 If intLeft < intRight Then intMid = (intLeft + intRight) \ 2 varTestVal = m_elements(intMid) i = intLeft j = intRight Do Do While m_elements(i) < varTestVal i = i + 1 Loop Do While m_elements(j) > varTestVal j = j - 1 Loop If i <= j Then Call Me.Swap(i, j) i = i + 1 j = j - 1 End If Loop Until i > j If j <= intMid Then Call QuickSort(intLeft, j) Call QuickSort(i, intRight) Else Call QuickSort(i, intRight) Call QuickSort(intLeft, j) End If End IfEnd SubPublic Function ContainsObjects() As Boolean Dim result As Boolean result = False Dim e As Variant For Each e In m_elements If IsObject(e) Then result = True Exit For End If Next e ContainsObjects = resultEnd FunctionPublic Function Items(Optional ByVal StartingIndex As Long = 0, Optional ByVal EndingIndex As Long = -1) As Variant() If EndingIndex = -1 Then EndingIndex = m_size - 1 Dim els() As Variant ReDim els(EndingIndex - StartingIndex) Dim i As Long Dim j As Long j = 0 If StartingIndex <= EndingIndex Then For i = StartingIndex To EndingIndex If Not IsObject(m_elements(i)) Then els(j) = m_elements(i) Else Set els(j) = m_elements(i) End If j = j + 1 Next i Else For i = StartingIndex To EndingIndex Step -1 If Not IsObject(m_elements(i)) Then els(j) = m_elements(i) Else Set els(j) = m_elements(i) End If j = j + 1 Next i End If Items = elsEnd FunctionPublic Function ToCollection() As Collection Dim coll As New Collection Dim i As Long For i = 0 To m_size - 1 coll.Add m_elements(i) Next i Set ToCollection = collEnd FunctionPublic Function ToArray() As Variant() ToArray = m_elementsEnd FunctionPublic Sub IntakeArray(yourArray() As Variant) 'array must be a variant array m_elements = yourArray m_capacity = Me.Capacity m_size = Me.LengthEnd SubPublic Sub IntakeCollection(ByVal yourCollection As Collection) 'completely replaces anything in m_elements with the elements of a collection 'do not use parentheses around the argument ReDim m_elements(yourCollection.Count - 1) Dim i As Long For i = 0 To UBound(m_elements) If IsObject(yourCollection.Item(i + 1)) Then Set m_elements(i) = yourCollection.Item(i + 1) Else: m_elements(i) = yourCollection.Item(i + 1) End If Next i m_capacity = Me.Capacity m_size = Me.LengthEnd Sub