A Simple List Class for VBA Projects

Introduction

This alternate modifies the original class code by declaring several undeclared variables and changing the assignment statement in the ListError() method. Revisions are preceded by 'rgl -

The original code did not force explicit variable declaration. Several variables were undeclared. With the addition of Option Explicit, the code using these variable wouldn't compile. Additionally, the original code included an incorrect assignment to an Error object.

Using the Code

Option Compare Database
Option Explicit

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
'rgl- correct assignment  ListError = mError to
    Set 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
'rgl - declare variable
    Dim a 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
'rgl - declare variable
    Dim i As Integer
    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
'rgl - declare variable
    Dim a As Integer
    
    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
    'rgl - declare variable
    Dim i As Integer
    
    Set list = list.CreateInstance
    
    For i = 0 To Count - 1
        list.Add mList(i)
    Next i
    Set GetCopy = list
    i = GetCopy.Count
End Function

History

• Insert Option Explicit and Option Database (for Access VBA)
• Declare previously undeclared variables.
• Change assignment to error (=) to Set in Property Get ListError