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
Public Sub Initialize()
Disposed = False
End Sub
Public Function CreateInstance() As vbaList
Dim oNew As New vbaList
oNew.Initialize
Set CreateInstance = oNew
End Function
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
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 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 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
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
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
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
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