VB实现List集合

Option Explicit

'***********************List集合 CArrayList.cls*****************************

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef psa() As Any) As Long

Private mArray()        As Variant

'添加元素
Public Sub Add(E As Variant)
        Dim Size As Long
        Size = Count()
        ReDim Preserve mArray(Size)
        mArray(Size) = E
End Sub

'插入元素
Public Sub Insert(ByVal Index As Long, E As Variant)
        Dim Size        As Long
        Dim i           As Long
        Size = Count()
        ReDim Preserve mArray(Size)
        For i = Size To Index + 1 Step -1
                mArray(i) = mArray(i - 1)
        Next i
        mArray(Index) = E
End Sub

'删除元素，通过索引
Public Sub Remove(ByVal Index As Long)
        If Count() = 0 Then
                Err.Raise vbError, , "下标越界"
                Exit Sub
        End If
        If Index < 0 Or Index > UpBound() Then
                Err.Raise vbError, , "下标越界"
                Exit Sub
        End If
        Dim i   As Long
        For i = Index To UpBound() - 1
                mArray(i) = mArray(i + 1)
        Next i
        If UpBound() > 0 Then
                ReDim Preserve mArray(UpBound() - 1)
        Else
                Erase mArray
        End If
End Sub

'删除项目
Public Sub RemoveItem(E As Variant)
        If Count() = 0 Then
                Exit Sub
        End If
        Dim i   As Long
        For i = 0 To UpBound()
                If mArray(i) = E Then
                        Remove i
                        Exit For
                End If
        Next i
End Sub



'元素数量
Public Function Count() As Long
        Count = UpBound() + 1
End Function

'元素上限
Public Function UpBound() As Long
        If SafeArrayGetDim(mArray) > 0 Then
                UpBound = UBound(mArray)
        Else
                UpBound = -1
        End If
End Function

'是否为空
Public Function IsEmpty() As Boolean
        IsEmpty = (Count() = 0)
End Function

'清除
Public Sub Clear()
        If Count() > 0 Then Erase mArray
End Sub

'获取项目值
Public Property Get Item(ByVal Index As Long) As Variant
        Item = mArray(Index)
End Property

'设置项目值
Public Property Let Item(ByVal Index As Long, E As Variant)
       mArray(Index) = E
End Property

'查找项目位置
Public Function IndexOf(E As Variant) As Long
        Dim i   As Long
        For i = 0 To UpBound()
                If Item(i) = E Then
                        IndexOf = i
                        Exit Function
                End If
        Next i
        IndexOf = -1
End Function

'包含项目
Public Function Contains(E As Variant) As Boolean
        Contains = (IndexOf(E) <> -1)
End Function

'包含集合
Public Function ContainsAll(List As CArrayList) As Boolean
        If List Is Nothing Then
                Exit Function
        End If
        Dim i   As Long
        For i = 0 To List.UpBound()
                If Not Contains(List.Item(i)) Then
                      Exit Function
                End If
        Next i
        ContainsAll = True
End Function

'移除集合
Public Sub RemoveAll(List As CArrayList)
        If List Is Nothing Then
                Exit Sub
        End If
        If IsEmpty() Then
                Exit Sub
        End If
                        
        Dim i   As Long
        For i = 0 To List.UpBound()
                RemoveItem List.Item(i)
        Next i
End Sub

'添加集合
Public Sub AddAll(List As CArrayList)
        If List Is Nothing Then
                Exit Sub
        End If
                        
        Dim i   As Long
        For i = 0 To List.UpBound()
                Add List.Item(i)
        Next i
End Sub

'获取迭代器
Public Function Iterator() As CIterator
        Dim It As New CIterator
        It.SetList Me
        Set Iterator = It
End Function

Option Explicit

'*****************迭代器 CIterator.cls************************


Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef psa() As Any) As Long

Private mList           As CArrayList
Private mIndex          As Long
Private HasElement      As Boolean

Private Sub Class_Initialize()
        mIndex = -1
End Sub

Public Sub SetList(List As CArrayList)
        Set mList = List
End Sub

'是否有下一个元素
Public Function HasNext() As Boolean
        If mIndex + 1 <= mList.UpBound() Then
                HasNext = True
        End If
End Function

'下一个元素
Public Function NextItem() As Variant
        mIndex = mIndex + 1
        NextItem = mList.Item(mIndex)
        HasElement = True
End Function

'删除当前元素
Public Function Remove()
        If Not HasElement Then
                Err.Raise vbError, , "迭代器无引用"
                Exit Function
        End If
        mList.Remove mIndex
        mIndex = mIndex - 1
        HasElement = False
End Function

Option Explicit

'**********************测试 frm_Test.frm**************************

Dim List As CArrayList
Dim i   As Long

Private Sub cmdAdd_Click()
        List.Add 100
        List.Add 101
        List.Add 102
        List.Add 103
End Sub

Private Sub cmdAddAll_Click()
        Dim mList As New CArrayList
        mList.Add 300
        mList.Add 400
        List.AddAll mList
End Sub

Private Sub cmdClear_Click()
        List.Clear
End Sub

Private Sub cmdContains_Click()
        Dim mList As New CArrayList
        mList.Add 100
        mList.Add 105
        MsgBox List.ContainsAll(mList)
End Sub

Private Sub cmdEnum_Click()
        Debug.Print "========="
        For i = 0 To List.UpBound()
                Debug.Print List.Item(i)
        Next i
End Sub

Private Sub cmdFind_Click()
        MsgBox List.IndexOf(200)
End Sub


Private Sub cmdInsert_Click()
        List.Insert 4, 300
End Sub

'迭代，可在遍历时删除
Private Sub cmdIterator_Click()
        Dim It As CIterator
        Set It = List.Iterator
        Dim v As Long
        Debug.Print "it================"
        While It.HasNext
                v = It.NextItem
                Debug.Print v
                If v = 101 Then
                        It.Remove
                End If
        Wend
End Sub

Private Sub cmdRemove_Click()
        List.Remove 1
End Sub

Private Sub cmdRemoveItem_Click()
        List.RemoveItem 102
End Sub

Private Sub cmdSet_Click()
        List.Item(1) = 200
End Sub


Private Sub cmdSize_Click()
        MsgBox "size: " & List.Count() & ",ubound: " & List.UpBound
End Sub

Private Sub Command1_Click()
        Dim mList As New CArrayList
        mList.Add 100
        mList.Add 102
        List.RemoveAll mList
End Sub

Private Sub Form_Load()
        Set List = New CArrayList
        
        
End Sub