This example will create a sorted collection of Person objects; the class will be named PersonCollection.

The first step is to create two classes to be used as interfaces: IComparable and IComparer. This classes resemble their Visual Basic.Net interface equivalents.

IComparable Class

'compare the current object to the referenced object

Public Function CompareTo(obj As Object)
End Function

The Person’s IComparable interface will be used by the PersonCollection’s Sort() method to provide the default sorting.

IComparer Class

'compare to referenced objects

Public Function Compare(x As Object, y As Object)
End Function

The PersonSorter’s IComparable interface will be used by the PersonCollection’s Sort() method to provide additional sorting options.

Person Class

The Person class has two relevant properties:

'--------------------------------------------------------------------------------
'Public Properties
'--------------------------------------------------------------------------------
'FileAs will be used to provide a default-sorting order.
Public Property Get FileAs() As String
FileAs = Me.LastName & ", " & Me.FirstName
End Property

'The Key property is used to provide the class' unique key.
Public Property Get Key As String
Key = "#" & Me.Id
End Property
'--------------------------------------------------------------------------------
'IComparable Methods
'--------------------------------------------------------------------------------
Private Function IComparable_CompareTo(obj As Object)

If Not TypeOf obj Is Person Then _
Err.Raise vbObjectError + 1, Err.Source, "The object is not a Person."

'convert the object to a Person
Dim Item As Person: Set Item = obj

'compare the FileAs field between the two instances.
If Me.FileAs > Item.FileAs Then
IComparable_CompareTo = 1
ElseIf Me.FileAs < Item.FileAs Then
IComparable_CompareTo = -1
Else
IComparable_CompareTo = 0
End If

End Function

The Person class exposes a CompareTo function to complete the interface inheritance:

'--------------------------------------------------------------------------------
'Public Methods
'--------------------------------------------------------------------------------
Public Function CompareTo(obj As Object)
CompareTo = IComparable_CompareTo(obj)
End Function

PersonSorter Class

The PersonSorter class implements the IComparer interface to provide a more-flexible set of sorting option. It uses the CallByName() function in combination with the ProcedureName property to do the actual work of comparison. In addition, the PersonSorter provides a means to change the direction of the sort using the Direction property.

'--------------------------------------------------------------------------------
'Public Properties
'--------------------------------------------------------------------------------
Public Direction As DirectionEnum
Public ProcedureName As String

'--------------------------------------------------------------------------------
'Public Methods
'--------------------------------------------------------------------------------
Public Function Compare(x As Object, y As Object) As Integer
Compare = IComparer_Compare(x, y)
End Function

Public Function ToString() As String
ToString = IObject_ToString
End Function
'--------------------------------------------------------------------------------
'IComparer Methods
'--------------------------------------------------------------------------------
Private Function IComparer_Compare(x As Object, y As Object) As Integer

If CallByName(x, ProcedureName, VbGet) > CallByName(y, ProcedureName, VbGet) Then
IComparer_Compare = 1 * Direction
ElseIf CallByName(x, ProcedureName, VbGet) < CallByName(y, ProcedureName, VbGet) Then
IComparer_Compare = -1 * Direction
Else
IComparer_Compare = 0
End If

End Function

The next challenge is to provide a means to swap two items in a collection. This is done via the Swap method:

Swap() Function

Private Sub Swap(ByRef Items As Collection, x As Long, y As Long)

'quality control
If x = y Then Exit Sub
If x < 0 Or y < 0 Then Exit Sub
If x > Items.Count Or y > Items.Count Then Exit Sub

'normalize positions
If x > y Then
Dim t As Long
t = x
x = y
y = t
End If

'store items temporarily
Dim ItemX As Object: Set ItemX = Items(x)
Dim ItemY As Object: Set ItemY = Items(y)

'remove items
Items.Remove y
Items.Remove x

'For the swap to work, the Key property must be created.  While this could be implemented as an interface, I chose to simplify matters and simply add it to the Person class.
'add y to x's position
If x > Items.Count Then
Items.Add ItemY, ItemY.Key
Else
Items.Add ItemY, ItemY.Key, x
End If

'add x to y's position
If y > Items.Count Then
Items.Add ItemX, ItemX.Key
Else
Items.Add ItemX, ItemX.Key, y
End If

'finalize
Set ItemX = Nothing
Set ItemY = Nothing

End Sub

Next, a mechanism is needed to sort the collection–the BubbleSort algorithm was adapted for for this purpose.

BubbleSort() Function

'Items - collection to be sorted 'Comparer - alternate sorting method Public Sub BubbleSort(ByRef Items As Collection, Optional Comparer As IComparer)

Dim i As Long, Sorted As Boolean

If Comparer Is Nothing Then

Do While Not Sorted
Sorted = True
For i = 1 To Items.Count - 1
If Items(i).CompareTo(Items(i + 1)) > 0 Then
Swap Items, i, i + 1
Sorted = False
End If
Next
Loop

Else

Do While Not Sorted
Sorted = True
For i = 1 To Items.Count - 1
If Comparer.Compare(Items(i), Items(i + 1)) > 0 Then
Swap Items, i, i + 1
Sorted = False
End If
Next
Loop

End If

End Sub

Usage

For basic usage, add items to the PersonCollection, the call the Sort() method:

Dim PC As New PersonCollection
With PC
.Add 1, "chris", "sellers", "6/13/1937"
.Add 5, "john", "gage", "10/10/1974"
.Add 3, "craig", "buchanan", "3/29/1966"
.Add 4, "jane", "buchanan", "12/26/1968"
.Add 2, "bill", "richards", "01/01/1900"
.Sort
End With

Enumerate PC

For more control, add a PersonSorter class:

Dim PS As New PersonSorter
With PS
.ProcedureName = "Age"
.Direction = DirectionEnum.Desc
End With

Dim PC As New PersonCollection
With PC
.Add 1, "chris", "sellers", "6/13/1937"
.Add 5, "john", "gage", "10/10/1974"
.Add 3, "craig", "buchanan", "3/29/1966"
.Add 4, "jane", "buchanan", "12/26/1968"
.Add 2, "bill", "richards", "01/01/1900"
.Sort PS
End With

Sub Enumerate(obj As Object)

Dim Item As Person
Debug.Print "--------------------------------------------------"
Dim o As IObject: Set o = obj.Comparer
Debug.Print o.tostring
Debug.Print "--------------------------------------------------"
For Each Item In obj
Debug.Print Item.Id & "; " & Item.FileAs & "; " & Item.Age
Next

End Sub

SortableCollection Project

Sortable Collection Project

Usage:

• Download the Contacts module
• Rename to Contacts.bas
• Open Outlook
• Press Alt+F11 to open the Visual-Basic editor
• Import Contacts.bas into Outlook
• Include a reference (Tools | References…) to ‘Microsoft Scripting Runtime’
• Change the destination’s path as desired
• Position cursor in Main
• Press F5