VBA ArrayList类 还可以继续扩展

Option Explicit

Private m_elements() As Variant
Private m_size As Long
Private m_capacity As Long
Private m_dic As Dictionary

Private Sub Class_Initialize()
ReDim m_elements(9)
m_size = 0
m_capacity = 10
Set m_dic = New Dictionary
End Sub

Public Property Get Capacity() As Long
'all capacity in the array, including unused space
Capacity = UBound(m_elements) + 1
End Property

Public Property Let Capacity(ByVal TotalCapacity As Long)
ReDim Preserve m_elements(TotalCapacity - 1)
m_capacity = TotalCapacity
End Property

Public Function Length() As Long
'includes only used elements in the array
Length = m_size
End Function

Private 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 If
End Sub

Private 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 If
End Sub

Public Function isEmpty() As Boolean
isEmpty = (m_size = 0)
End Function

Public 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 + 1
End Sub

Sub 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 trimToSize
End Sub

Public 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 If
End Property

Public 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 If
End Property

Public 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 If
End Property

Public 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 i
End Sub

Public 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 trimToSize
End Sub

Public 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 i
End Sub

Public 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 = result
End Function

Public 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 = result
End Function

Public 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 = result
End Function

Public Sub Clear()
ReDim m_elements(9)
m_capacity = 10
m_size = 0
End Sub

Private 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 If
End Sub

Public 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 If
End Sub

Public 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 If
End Sub

Public 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 i
End Sub

Public 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 = distinctVals
End Function

Public 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 = newAL
End Function

Public 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(<number>) as <datatype> or redim array1(<number>)

'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 i
End Sub

Public 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 If
End Sub

Private 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 If
End Sub

Public 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 = result
End Function

Public 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 = els
End Function

Public 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 = coll
End Function

Public Function ToArray() As Variant()
ToArray = m_elements
End Function

Public Sub IntakeArray(yourArray() As Variant)
'array must be a variant array
m_elements = yourArray
m_capacity = Me.Capacity
m_size = Me.Length
End Sub

Public 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.Length
End Sub