Bit of an esoteric title, but let me explain. I wanted to create an IComparer that can be supplied to a sorting algorithm, which rather than using the >, <, = comparison operators on the two values, or some custom property of 2 objects like this fantastic PropertyComparer class, instead lets the user decide manually which of 2 items is "better" and should be ranked higher in the list.

At the same time I wanted to dip my toes in the MVVM framework that @Matt posted a while back by creating a really simple form that just presents the two options x and y being compared and lets the user click on the one they want. Here's how it turned out:

Fuzzy gif

By using mscorlib.ArrayList which implements the QuickSort algorithm, and adding a cache to save the result of every comparison in case it comes up again, a minimal number of comparisons is required to sort the list.


The simplest place to start is the View TextRepresentableThingsView:

'@Folder "ThingComparer"
Option Explicit
Implements IView
Implements ICancellable

Private Type TState
    Context As MVVM.IAppContext
    ViewModel As ThingComparisonViewModel
    IsCancelled As Boolean
End Type

Private this As TState

Implements IThingComparisonViewFactory

'@Description "Creates a new instance of this form."
Private Function IThingComparisonViewFactory_Create(ByVal Context As MVVM.IAppContext, ByVal ViewModel As ThingComparisonViewModel) As IView
    Dim result As TextRepresentableThingsView
    Set result = New TextRepresentableThingsView
    Set result.Context = Context
    Set result.ViewModel = ViewModel
    Set IThingComparisonViewFactory_Create = result
End Function

Public Property Get Context() As MVVM.IAppContext
    Set Context = this.Context
End Property

Public Property Set Context(ByVal RHS As MVVM.IAppContext)
    Set this.Context = RHS
End Property

Friend Property Set ViewModel(ByVal RHS As Object)
    Set this.ViewModel = RHS
End Property

Private Sub OnCancel()
    this.IsCancelled = True
End Sub

Private Sub InitializeView()
    With this.Context.Bindings

        'these are just captions so only need one way
        .BindPropertyPath this.ViewModel, "ThingX", Me.ThingXLabel, Mode:=OneTimeBinding
        .BindPropertyPath this.ViewModel, "ThingY", Me.ThingYLabel, Mode:=OneTimeBinding
    End With
    With this.Context.Commands
        .BindCommand this.ViewModel, Me.ThingXLabel, this.ViewModel.SelectXCommand(Me)
        .BindCommand this.ViewModel, Me.ThingYLabel, this.ViewModel.SelectYCommand(Me)
    End With
    this.Context.Bindings.Apply this.ViewModel
End Sub

Private Property Get ICancellable_IsCancelled() As Boolean
    ICancellable_IsCancelled = this.IsCancelled
End Property

Private Sub ICancellable_OnCancel()
End Sub

Private Sub IView_Hide()
End Sub

Private Sub IView_Show()
    Me.Show vbModal
End Sub

Private Function IView_ShowDialog() As Boolean
    Me.Show vbModal
    IView_ShowDialog = Not this.IsCancelled
End Function

Private Property Get IView_ViewModel() As Object
    Set IView_ViewModel = this.ViewModel
End Property

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = VbQueryClose.vbFormControlMenu Then
        Cancel = True
    End If
End Sub

... which is the code-behind for a userform with 2 labels - ThingXLabel and ThingYLabel in a frame with some instructions. Userform snap

It is a TextRepresentableThingsView because I envisage an ImagesView or a ClassFooView could also be used which allow different things to be displayed*, whilst still sticking to the fundamental "choose one or the other" behaviour, defined, incidentally, in the ViewModel ThingComparisonViewModel:

'@Folder "ThingComparer"
Option Explicit

'Implements INotifyPropertyChanged

Private Type TState
    ThingX As String
    ThingY As String
    Handler As IHandlePropertyChanged
    Choice As ComparisonResult
End Type

Public Enum ComparisonResult
End Enum

Private this As TState

Public Property Get Choice() As ComparisonResult
    Choice = this.Choice
End Property

Public Property Let Choice(ByVal RHS As ComparisonResult)
    this.Choice = RHS
End Property

'@Ignore ProcedureNotUsed: Called by name by MVVM framework
Public Property Get ThingX() As String
    ThingX = this.ThingX
End Property

Public Property Let ThingX(ByVal RHS As String)
    this.ThingX = RHS
End Property

'@Ignore ProcedureNotUsed
Public Property Get ThingY() As String
    ThingY = this.ThingY
End Property

Public Property Let ThingY(ByVal RHS As String)
    this.ThingY = RHS
End Property

Public Property Get SelectXCommand(ByVal View As IView) As ICommand
    Set SelectXCommand = SelectOptionCommand.Create(ThingXClick, View)
End Property

Public Property Get SelectYCommand(ByVal View As IView) As ICommand
    Set SelectYCommand = SelectOptionCommand.Create(ThingYClick, View)
End Property

'Private Sub INotifyPropertyChanged_OnPropertyChanged(ByVal Source As Object, ByVal PropertyName As String)
'    this.Handler.HandlePropertyChanged Source, PropertyName
'End Sub
'Private Sub INotifyPropertyChanged_RegisterHandler(ByVal Handler As IHandlePropertyChanged)
'    Set this.Handler = Handler
'End Sub

Considering Matt's article says the ViewModel is where the bulk of the work is, I'm slightly worried there isn't much going on here. All it does is holds the two items being compared, and the result of the comparison. It provides some custom Select[X|Y]Commands which are instances of the SelectOptionCommand:

'@Folder "ThingComparer"
Option Explicit

Implements ICommand

Public Enum CommandType
End Enum

Private Type TState
    View As IView
    ClickType As CommandType
End Type

Private this As TState

Public Function Create(ByVal ClickType As CommandType, ByVal View As IView) As SelectOptionCommand
    Dim result As SelectOptionCommand
    Set result = New SelectOptionCommand
    result.ClickType = ClickType
    Set result.View = View
    Set Create = result
End Function

Friend Property Let ClickType(ByVal RHS As CommandType)
    this.ClickType = RHS
End Property

Friend Property Set View(ByVal RHS As IView)
    GuardClauses.GuardDefaultInstance Me, SelectOptionCommand
    GuardClauses.GuardDoubleInitialization this.View, TypeName(Me)
    Set this.View = RHS
End Property

Private Function ICommand_CanExecute(ByVal Context As Object) As Boolean
    ICommand_CanExecute = True
End Function

Private Property Get ICommand_Description() As String
    ICommand_Description = "Click to select"
End Property

Private Sub ICommand_Execute(ByVal Context As Object)
    Dim ViewModel As ThingComparisonViewModel
    Set ViewModel = Context 'REVIEW: Or this.View.ViewModel
    'just need to save click result
    Select Case this.ClickType
        Case ThingXClick: ViewModel.Choice = xChosen
        Case ThingYClick: ViewModel.Choice = yChosen
    End Select
End Sub

I found a bit weird the way they need a reference to View which might create a circular reference, but I guess it's okay as long as the View holds references to the Commands, the ViewModel just acts as a factory.

*my default instinct would be to make the things IDrawable, but I think multiple views is closer to the MVVM paradigm?


Speaking of factories, I made the View implement its own strongly typed factory method IThingComparisonViewFactory:

'@Folder "ThingComparer"
Option Explicit

Public Function Create(ByVal Context As MVVM.IAppContext, ByVal ViewModel As ThingComparisonViewModel) As IView
End Function

... that way I know that all IViews will really be more like IView<ThingComparisonViewModel> as opposed to generic ones (this is something I find weird in MVVM, how do we enforce a View implementation will be compatible with a particular ViewModel?).

The factory is used by the MVVM coordinator which constructs the Context, ViewModel and View objects. It is also the top level API which implements IComparable GUIComparer:

'@Folder "ThingComparer"
Option Explicit

Implements mscorlib.IComparer

Private Type TGUIComparer
    View As IView
End Type

Private this As TGUIComparer

Private Property Get View() As IView
    Set View = this.View
End Property

Friend Property Set View(ByVal RHS As IView)
    Set this.View = RHS
End Property

Public Function Create(Optional ByVal ViewFactory As IThingComparisonViewFactory) As GUIComparer
    GuardClauses.GuardNonDefaultInstance Me, GUIComparer

    Dim result As GUIComparer
    Set result = New GUIComparer
    Dim Context As IAppContext
    Set Context = AppContext.Create()
    Dim ViewModel As ThingComparisonViewModel
    Set ViewModel = New ThingComparisonViewModel
    If ViewFactory Is Nothing Then Set ViewFactory = TextRepresentableThingsView
    Set result.View = ViewFactory.Create(Context, ViewModel)
    Set Create = result
End Function

Private Function IComparer_Compare(ByVal x As Variant, ByVal y As Variant) As Long

    GuardClauses.GuardDefaultInstance Me, GUIComparer 'cache won't be clear in the default instance
    GuardClauses.GuardNullReference View, Message:="Class must be Created with the .Create Method not `New`"
    'short circuit default condition
    'our list has no dupes but arraylist asserts x.compareTo(x) = 0
    If x = y Then IComparer_Compare = 0: Exit Function
    'only need to check x & y as reverse is already in cache by default
    Static cache As New Scripting.Dictionary
    If TryGetComparisonResult(cache, x, y, IComparer_Compare) Then Exit Function

    With View
        Dim ViewModel As ThingComparisonViewModel
        Set ViewModel = .ViewModel
        ViewModel.ThingX = x
        ViewModel.ThingY = y
        'show dialog so we can capture cancellation
        If Not .ShowDialog Then Err.Raise 5, , "Cancelled"
        Select Case ViewModel.Choice
            Case xChosen
                IComparer_Compare = -1
            Case yChosen
                IComparer_Compare = 1
            Case Else
                Err.Raise 5, , "Invalid Selection"
        End Select
    End With
    CacheComparisonResult cache, x, y, IComparer_Compare
End Function

'TODO revisit this cache. It wants to be a map<(variant,variant):bool> where the variants are commutative
'Right now this won't work with objects, only value types, so it is tightly coupled to the TextRepresentableThingsView
Private Function TryGetComparisonResult(ByVal cache As Dictionary, ByVal x As Variant, ByVal y As Variant, ByRef outValue As Long) As Boolean
    Dim key As String
    key = x & vbNullChar & y
    If Not cache.Exists(key) Then Exit Function
    TryGetComparisonResult = True
    outValue = cache.Item(key)
End Function

Private Sub CacheComparisonResult(ByVal cache As Dictionary, ByVal x As Variant, ByVal y As Variant, ByVal result As Long)
    cache.Add x & vbNullChar & y, result
    cache.Add y & vbNullChar & x, -result
End Sub

Using the IComparer is very simple as you could see in the video, but some example code:

Sub SortSelection()

    Dim list As New mscorlib.ArrayList
    Dim rangeToSort As Range
    Set rangeToSort = Selection
    Dim item As Range
    For Each item In rangeToSort
        list.Add item.Value
    Next item
    list.sort_2 GUIComparer.Create(ViewFactory:=TextRepresentableThingsView)
    dumpList list, dumpWhere:=rangeToSort
End Sub

Private Sub dumpList(ByVal list As ArrayList, Optional ByVal dumpWhere As Range)
    If dumpWhere Is Nothing Then Set dumpWhere = ThisWorkbook.Sheets.Add().Range("A1")
    dumpWhere.Resize(list.Count, 1).Value = WorksheetFunction.Transpose(list.ToArray)
End Sub

Try it out in this download workbook


  • MVVM framework is truly magic
  • I was wondering, instead of having a SelectOptionCommand to hide the view and update the state, I could just have an AcceptCommand wired up to each label, then use a property binding to see what control has focus. Not sure how to do that or what is more idiomatic?
  • As mentioned, not sure what's the best way to handle things that need a different kind of representation. For example if I am sorting a list of filepaths to photos, which need to be displayed differently.
    • Should my View be clever enough to detect the types of ViewModel.ThingX and draw accordingly
    • Should I inject a different view for each type as I have outlined now
    • Should I be getting IDrawable things fed into the Comparer so I only need one View implementation which can have drawing method dictated to it by the types supplied by the ViewModel (i.e. Thing[X/Y] manage their own representation.)
  • Finally, I want to add some more GUI juice, specifically a hoverover animation - should this be in command bindings or property bindings?

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.