VBA 项目的简单列表类

Stefan Huy

4.90/5 (7投票s)

2013年12月16日

CPOL

1分钟阅读

66580

献给那些非常怀念 VBA 中 .NET 风格 List 的人

引言

这个 VBA 类代码在您的 VBA 项目中实现了一个类似于 .NET 的对象 List (List<T>)，以避免使用不方便的 VBA 数组。请原谅我拙劣的英语，希望大部分内容都能理解。:)

背景

有时，我需要修改一些旧的 Excel VBA 项目，并且非常怀念列表实现，因为我需要用数组处理所有内容。所以我决定编写自己的列表类，其中实现了 .NET List 的大多数方法和属性。只需将代码复制到您的 VBA 项目中作为类即可。稍后，我会尝试在代码本身中添加一些解释。

Using the Code

为了模拟一个 List，我决定使用标准的 VBA Array 和数据类型 variant，以便可以将任何数据类型添加到 Array 中。在使用 Sort 方法时，我仍然遇到一些问题，但我希望找到一些时间将排序功能添加到 Array 中。

目前，已实现以下属性和方法/函数

属性

Count()
Disposed()
GotError()
ListError()
ListItems()

方法

Add(ByRef vItem As Variant, Optional index As Long)
Clear()
Contains(ByRef vItem As Variant)
Copy()
Exists(vItem As Variant)
Find(ByRef vItem As Variant)
Dispose()
IndexOf(ByRef vItem As Variant)
LastIndexOf(ByRef vItem As Variant)
Remove()
RemoveAll()
RemoveAtIndex(ByRef index As Long)
ResetError()
Reverse()
Sort()
ToArray()

将代码复制到一个新的 VBA 类中。类名**必须**为 VbaList！如果您想更改名称，请不要忘记同时更改类代码中的引用。

这是完整的类代码

Private mList() As Variant
Private mError As Error
Private mDisposed As Boolean

'==============================
'Constructor
'==============================
Public Sub Initialize()
    Disposed = False
End Sub

Public Function CreateInstance() As vbaList
    Dim oNew As New vbaList
    oNew.Initialize
    Set CreateInstance = oNew
End Function

'==============================
'Properties
'==============================
Public Property Get Items(ByRef index As Long) As Variant
    Items = GetItemAtIndex(index)
End Property
    Public Property Get Count() As Long
    Count = GetListCount()
End Property

Public Property Get GotError() As Boolean
    If ListError Is Nothing Then GotError = False Else GotError = True
End Property

Public Property Get ListItems() As Variant()
    ClearError
    On Error GoTo Err
    ListItems = mList
    Exit Property
    Err:
        ListError = Err
End Property

Public Property Get ListError() As Error
    ListError = mError
End Property

Private Property Let ListError(ByRef vError As Error)
    Set mError = vError
End Property

Public Property Get Disposed() As Boolean
    Disposed = mDisposed
End Property

Private Property Let Disposed(ByRef vValue As Boolean)
    mDisposed = vValue
End Property

Public Property Get ToArray()
    ToArray = mList
End Property

'==============================
'Public Methods
'==============================

Public Sub Remove(ByRef vItem As Variant)
    DeleteElement (vItem)
End Sub

Public Sub RemoveAtIndex(ByRef index As Long)
    DeleteElementAt (index)
End Sub

Public Sub Sort()
    BubbleSort (mList)
End Sub

Public Sub Clear()
    Erase mList
End Sub

Public Function Find(ByRef vItem As Variant) As Long
    Find = FindItem(vItem)
End Function

Public Sub Dispose()
    ResetError
    Clear
    Disposed = True
End Sub

Public Sub ResetError()
    ClearError
End Sub

Public Function LastIndexOf(ByRef vItem As Variant)
    LastIndexOf = GetLastIndexOf(vItem)
End Function

Public Function IndexOf(ByRef vItem As Variant)
    IndexOf = FindItem(vItem)
End Function

Public Sub Reverse()
    ReverseList
End Sub

Public Function Exists(vItem As Variant)
    Exists = ItemExists(vItem)
End Function

Public Sub Add(ByRef vItem As Variant, Optional index As Long)
    If index > 0 Then
        AddItemAt index, vItem
    Else
        AddItem vItem
    End If
End Sub

Public Function Contains(ByRef vItem As Variant)
    Contains = Exists(vItem)
End Function

Public Function Copy() As vbaList
    Set Copy = GetCopy
End Function

Public Sub RemoveAll()
    Clear
End Sub

'==============================
'Private Methods
'==============================

Private Sub ClearError()
    Set mError = Nothing
End Sub

Private Function GetListCount() As Long
    ClearError
    On Error GoTo Err
    GetListCount = UBound(mList) - LBound(mList) + 1
    Exit Function
    Err:
        GetListCount = 0
End Function

Private Function GetItemAtIndex(ByRef index As Long) As Variant
    ClearError
    On Error GoTo Err
    GetItemAtIndex = mList(index)
    Exit Function
    Err:
        ListError = Err
    GetItemAtIndex = Nothing
End Function

Private Sub AddItemAt(index As Long, vItem As Variant)
    ClearError
    On Error GoTo Err

    Dim ar() As Variant
    Dim i As Integer

    i = Count
    ReDim ar(i)

    For a = 0 To index - 1
        ar(a) = mList(a)
    Next

    ar(index) = vItem

    For a = index + 1 To i
        ar(a) = mList(a - 1)
    Next

    mList = ar
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Sub BubbleSort(ByVal vArray As Variant)
    ClearError
    On Error GoTo Err

    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim vSwap As Variant
    Dim swapped As Boolean

    iMin = LBound(vArray)
    iMax = UBound(vArray) - 1

    Do
        swapped = False
    For i = iMin To iMax
        If vArray(i) > vArray(i + 1) Then
            vSwap = vArray(i)
            vArray(i) = vArray(i + 1)
            vArray(i + 1) = vSwap
            swapped = True
        End If
    Next
    iMax = iMax - 1
    Loop Until Not swapped
    mList = vArray
    Erase vArray
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Sub DeleteElementAt(index As Integer)
    ClearError
    On Error GoTo Err

    Dim i As Integer
    For i = index + 1 To Count - 1
        mList(i - 1) = mList(i)
    Next
    ReDim Preserve mList(Count - 2)
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Sub DeleteElement(ByRef vItem As Variant)
    ClearError
    On Error GoTo Err

    DeleteElementAt (FindItem(vItem))
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Sub AddItem(vItem As Variant)
    ClearError
    On Error GoTo Err

    Dim i As Long
    i = Count
    ReDim Preserve mList(i)
    mList(i) = vItem
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Function FindItem(vItem As Variant) As Long
    ClearError
    On Error GoTo Err

    FindItem = -1

    For i = 0 To Count - 1
        If mList(i) = vItem Then
        FindItem = i
        Exit For
        End If
    Next i
    Exit Function
    Err:
        ListError = Err
        FindItem = -1
End Function

Private Function GetLastIndexOf(vItem As Variant) As Long
    ClearError
    On Error GoTo Err

    GetLastIndexOf = -1
    Dim i As Long

    For i = Count - 1 To 0 Step -1
        If mList(i) = vItem Then
            GetLastIndexOf = i
        Exit Function
        End If
    Next i
    Exit Function
    Err:
        ListError = Err
        GetLastIndexOf = -1
End Function

Private Sub ReverseList()
    ClearError
    On Error GoTo Err

    Dim ar() As Variant
    Dim i As Long
    Dim j As Long

    If Count = 0 Then Exit Sub
    i = Count - 1
    j = i
    ReDim ar(i)

    For a = 0 To i
        ar(a) = mList(j)
        j = j - 1
    Next a

    mList = ar
    Erase ar
    Exit Sub
    Err:
        ListError = Err
End Sub

Private Function ItemExists(vItem As Variant) As Boolean
    If FindItem(vItem) > -1 Then
        ItemExists = True
    Else
        ItemExists = False
    End If
End Function

Private Function GetCopy() As vbaList
    Dim list As New vbaList
    Set list = list.CreateInstance
    
    For i = 0 To Count - 1
        list.Add mList(i)
    Next i
    Set GetCopy = list
    i = GetCopy.Count
End Function

这是一个小示例。为了测试，将代码复制到 VBA 模块

Sub test()
    Dim list As New vbaList
    Set list = list.CreateInstance

    list.Add 1
    list.Add 9
    list.Add 6
    list.Add 13
    list.Add 2
    list.Add 6
    list.Add 4, 3
    list.Remove 13
    list.RemoveAtIndex 2
    list.Add "Test 1"
    list.Add "Test 2"
    list.Add 6
 
    Dim listCopy As New vbaList
    Set listCopy = list.Copy

    Dim i As Long

    Debug.Print "========================================"
    Debug.Print "IndexOf Pos: " & list.IndexOf(6)
    Debug.Print "LastIndexOf Pos: " & list.LastIndexOf(6)
    Debug.Print "Find Test 1 @ Pos: " & list.Find("Test 1")
    Debug.Print "[Test 1] exists: " & list.Exists("Test 1")
    Debug.Print "[Test 3] exists: " & list.Exists("Test 3")
    Debug.Print "Count: " & list.Count
    list.Clear
    Debug.Print "Clear() Count: " & list.Count
    list.Dispose
    Debug.Print "Disposed: " & list.Disposed
    
    Debug.Print ""
    For i = 0 To listCopy.Count - 1
        Debug.Print "Default - Pos " & i & ": " & listCopy.Items(i)
    Next i
    listCopy.Reverse
    For i = 0 To listCopy.Count - 1
        Debug.Print "Reverse - Pos " & i & ": " & listCopy.Items(i)
    Next i
End Sub