14
\$\begingroup\$

Following-up on this post where I implemented a Repository Pattern in to abstract ADODB and enable testing my Excel app without hitting a database backend; curious about how far would let me push and loose coupling, I decided to grab the red pill, and see how deep the rabbit hole goes.


Presentation

With the original design, despite the decoupled data access, I still would have needed a form for every table I wanted to maitain, since the presentation logic was still coupled with the views.

I scratched that, and created a SimpleView form that I intended to use for anything I would want to maintain with that application, now or in the future.

design-time CRUD form

SimpleView form

Option Explicit

Private Type ViewModel
    Model As SqlResult
    Selection As SqlResultRow
    Callback As ICommandCallback
End Type

Private vm As ViewModel

Private minHeight As Integer
Private minWidth As Integer
Private layoutBindings As New List

Implements IView

Private Sub UserForm_Initialize()

    minHeight = Me.Height
    minWidth = Me.Width

    BindControlLayouts

End Sub

Private Sub BindControlLayouts()

    Dim backgroundImageLayout As New ControlLayout
    backgroundImageLayout.Bind Me, BackgroundImage, AnchorAll

    Dim closeButtonLayout As New ControlLayout
    closeButtonLayout.Bind Me, CloseButton, BottomAnchor + RightAnchor

    Dim itemsListLayout As New ControlLayout
    itemsListLayout.Bind Me, ItemsList, AnchorAll

    Dim addButtonLayout As New ControlLayout
    addButtonLayout.Bind Me, AddButton, RightAnchor

    Dim editButtonLayout As New ControlLayout
    editButtonLayout.Bind Me, EditButton, RightAnchor

    Dim showDetailsButtonLayout As New ControlLayout
    showDetailsButtonLayout.Bind Me, ShowDetailsButton, RightAnchor

    Dim deleteButtonLayout As New ControlLayout
    deleteButtonLayout.Bind Me, DeleteButton, RightAnchor

    layoutBindings.Add closeButtonLayout, _
                       backgroundImageLayout, _
                       itemsListLayout, _
                       addButtonLayout, _
                       editButtonLayout, _
                       showDetailsButtonLayout, _
                       deleteButtonLayout

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = True
    Hide
End Sub

Private Sub UserForm_Resize()

    Application.ScreenUpdating = False

    If Me.Width < minWidth Then Me.Width = minWidth
    If Me.Height < minHeight Then Me.Height = minHeight

    Dim layout As ControlLayout
    For Each layout In layoutBindings
        layout.Resize Me
    Next

    Application.ScreenUpdating = True

End Sub

Public Property Get Model() As SqlResult
    Set Model = vm.Model
End Property

Public Property Set Model(ByVal value As SqlResult)
    Set vm.Model = value
    OnModelChanged
End Property

Public Property Get SelectedItem() As SqlResultRow
    Set SelectedItem = vm.Selection
End Property

Public Property Set SelectedItem(ByVal value As SqlResultRow)

    If (Not (value Is Nothing)) Then
        If (ObjPtr(value.ParentResult) <> ObjPtr(vm.Model)) Then

            Set value.ParentResult = vm.Model

        End If
    End If

    Set vm.Selection = value
    EvaluateCanExecuteCommands

End Property

Private Sub EvaluateCanExecuteCommands()

    AddButton.Enabled = vm.Callback.CanExecute(ExecuteAddCommand)
    CloseButton.Enabled = vm.Callback.CanExecute(ExecuteCloseCommand)
    DeleteButton.Enabled = vm.Callback.CanExecute(ExecuteDeleteCommand)
    EditButton.Enabled = vm.Callback.CanExecute(ExecuteEditCommand)
    ShowDetailsButton.Enabled = vm.Callback.CanExecute(ExecuteShowDetailsCommand)

End Sub

Public Sub Initialize(cb As ICommandCallback, ByVal ViewModel As SqlResult, ByVal title As String, ByVal commands As ViewAction)

    Localize title
    Set vm.Callback = cb
    Set Model = ViewModel

    AddButton.Visible = commands And ViewAction.Create
    EditButton.Visible = commands And ViewAction.Edit
    DeleteButton.Visible = commands And ViewAction.Delete
    ShowDetailsButton.Visible = commands And ViewAction.ShowDetails

End Sub

Private Sub Localize(ByVal title As String)

    Me.Caption = title
    CloseButton.Caption = GetResourceString("CloseButtonText")

    InstructionsLabel.Caption = GetResourceString("SimpleViewInstructionsText")

    AddButton.ControlTipText = GetResourceString("AddButtonToolTip")
    EditButton.ControlTipText = GetResourceString("EditButtonToolTip")
    DeleteButton.ControlTipText = GetResourceString("DeleteButtonToolTip")
    ShowDetailsButton.ControlTipText = GetResourceString("ShowDetailsButtonToolTip")

End Sub

Private Sub OnModelChanged()

    ItemsList.Clear
    If vm.Model Is Nothing Then Exit Sub
    vm.Model.ValueSeparator = StringFormat("\t")

    Dim row As SqlResultRow
    For Each row In vm.Model

        Set row.ParentResult = vm.Model
        ItemsList.AddItem row.ToString

    Next

End Sub

Private Sub AddButton_Click()
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteAddCommand
End Sub

Private Sub DeleteButton_Click()
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteDeleteCommand
End Sub

Private Sub CloseButton_Click()
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteCloseCommand
End Sub

Private Sub EditButton_Click()
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteEditCommand
End Sub

Private Sub ShowDetailsButton_Click()
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteShowDetailsCommand
End Sub

Private Sub ItemsList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If vm.Callback.CallbackOwner Is Nothing Then Exit Sub
    vm.Callback.Execute ExecuteEditCommand
End Sub

Private Sub ItemsList_Change()
    If ItemsList.ListIndex >= 0 Then
        Set SelectedItem = vm.Model(ItemsList.ListIndex)
    Else
        Set SelectedItem = Nothing
    End If
End Sub

Private Sub IView_Initialize(cb As ICommandCallback, ByVal ViewModel As SqlResult, ByVal title As String, ByVal commands As ViewAction)
    Initialize cb, ViewModel, title, commands
End Sub

Private Property Get IView_CommandCallback() As ICommandCallback
    Set IView_CommandCallback = vm.Callback
End Property

Private Property Set IView_Model(ByVal value As SqlResult)
    Set Model = value
End Property

Private Property Get IView_Model() As SqlResult
    Set IView_Model = Model
End Property

Private Property Set IView_SelectedItem(ByVal value As SqlResultRow)
    Set SelectedItem = value
End Property

Private Property Get IView_SelectedItem() As SqlResultRow
    Set IView_SelectedItem = SelectedItem
End Property

Private Sub IView_Show()
    Show
End Sub

Private Sub IView_Hide()
    Hide
End Sub

Talking to someone you can't see

I was thrilled to see let me use the Implements keyword on a form, and do Implements IView. But when I went and created the IView interface, I was hoping to be able to use events, so that the view could tell the presenter about things such as "user clicked a button, do something about it".

The problem is that Implements doesn't support events. But instead of thinking "I guess that's the bottom of the rabbit hole", I came up with this:

CommandCallback class module

Option Explicit

Private owner As IPresenter
Private method As CallbackMethodName
Private methodNames As New Dictionary

Implements ICommandCallback

Private Sub Class_Initialize()
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteCloseCommand), "ExecuteCloseCommand"
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteAddCommand), "ExecuteAddCommand"
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteDeleteCommand), "ExecuteDeleteCommand"
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteEditCommand), "ExecuteEditCommand"
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteRefreshCommand), "ExecuteRefreshCommand"
    methodNames.Add "cb" & CStr(CallbackMethodName.ExecuteShowDetailsCommand), "ExecuteShowDetailsCommand"
End Sub

Public Property Get CallbackOwner() As IPresenter
    Set CallbackOwner = owner
End Property

Public Property Set CallbackOwner(ByVal value As IPresenter)
    Set owner = value
End Property

Public Function CanExecute(ByVal cb As CallbackMethodName) As Boolean
    If owner Is Nothing Then Exit Sub
    CanExecute = CallByName(owner, "Can" & methodNames("cb" & CStr(cb)), VbMethod)
End Function

Public Sub Execute(ByVal cb As CallbackMethodName)
    If owner Is Nothing Then Exit Sub
    CallByName owner, methodNames("cb" & CStr(cb)), VbMethod
End Sub

Private Property Set ICommandCallback_CallbackOwner(ByVal value As IPresenter)
    Set CallbackOwner = value
End Property

Private Property Get ICommandCallback_CallbackOwner() As IPresenter
    Set ICommandCallback_CallbackOwner = CallbackOwner
End Property

Private Function ICommandCallback_CanExecute(ByVal cb As CallbackMethodName) As Boolean
    ICommandCallback_CanExecute = CanExecute(cb)
End Function

Private Sub ICommandCallback_Execute(ByVal cb As CallbackMethodName)
    If ICommandCallback_CanExecute(cb) Then Execute cb
End Sub

Presenter Implementations

Presenter implementations are all going to be pretty similar, almost in a boring way. Here's one that implements every feature (other implementations may not be implementing all commands):

CustomerGroupsPreseter class module

Option Explicit

Private service As IRepository
Private details As IPresenter
Private vw As IView

Implements IPresenter

Public Property Get Repository() As IRepository
    Set Repository = service
End Property

Public Property Set Repository(ByVal value As IRepository)
    Set service = value
End Property

Public Property Get View() As IView
    Set View = vw
End Property

Public Property Set View(ByVal value As IView)
    Set vw = value
End Property

Public Property Get DetailsPresenter() As IPresenter
    Set DetailsPresenter = details
End Property

Public Property Set DetailsPresenter(ByVal value As IPresenter)
    Set details = value
End Property

Public Sub Show()
    Refresh
    View.Show
End Sub

Private Sub Refresh()
    Dim Model As SqlResult
    Set Model = service.GetAll
    Set View.Model = Model
End Sub

Private Function NewCustomerGroup(Optional ByVal id As Long = 0, Optional ByVal description As String = vbNullString) As SqlResultRow

    Dim result As SqlResultRow

    Dim values As New Dictionary
    values.Add "Id", id
    values.Add "Description", description

    Set result = Repository.NewItem(View.Model, values)
    Set NewCustomerGroup = result

End Function

Private Sub Class_Terminate()
    Unload View
End Sub

Private Function IPresenter_CanExecuteAddCommand() As Boolean
    IPresenter_CanExecuteAddCommand = True
End Function

Private Function IPresenter_CanExecuteCloseCommand() As Boolean
    IPresenter_CanExecuteCloseCommand = True
End Function

Private Function IPresenter_CanExecuteDeleteCommand() As Boolean
    IPresenter_CanExecuteDeleteCommand = Not View.SelectedItem Is Nothing
End Function

Private Function IPresenter_CanExecuteEditCommand() As Boolean
    IPresenter_CanExecuteEditCommand = Not View.SelectedItem Is Nothing
End Function

Private Function IPresenter_CanExecuteRefreshCommand() As Boolean
    IPresenter_CanExecuteRefreshCommand = True
End Function

Private Function IPresenter_CanExecuteShowDetailsCommand() As Boolean

    If View.SelectedItem Is Nothing Then Exit Function

    Dim detailsModel As SqlResult
    Set detailsModel = details.Repository.GetAll.WhereFieldEquals("CustomerGroupId", View.SelectedItem("Id"))

    IPresenter_CanExecuteShowDetailsCommand = detailsModel.Count > 0

End Function

Private Property Set IPresenter_DetailsPresenter(ByVal value As IPresenter)
    Set DetailsPresenter = value
End Property

Private Property Get IPresenter_DetailsPresenter() As IPresenter
    Set IPresenter_DetailsPresenter = DetailsPresenter
End Property

Public Sub ExecuteRefreshCommand()
    Set View.Model = Repository.GetAll
End Sub

Public Sub ExecuteShowDetailsCommand()

    Dim detailsModel As SqlResult
    Set detailsModel = details.Repository.GetAll.WhereFieldEquals("CustomerGroupId", View.SelectedItem("Id"))

    Set details.View.Model = detailsModel
    details.Show

End Sub

Private Sub IPresenter_ExecuteShowDetailsCommand()
    ExecuteShowDetailsCommand
End Sub

Public Sub ExecuteAddCommand()

    Dim description As String
    If Not RequestUserInput(prompt:="Please enter a description for the new CustomerGroup:", _
                            title:="Edit", _
                            outResult:=description, _
                            default:="(new customer group)") _
    Then
        Exit Sub
    End If

    Repository.Add NewCustomerGroup(description:=description)
    Refresh

End Sub

Public Sub ExecuteCloseCommand()
    View.Hide
End Sub

Public Sub ExecuteDeleteCommand()

    Dim id As Long
    id = View.SelectedItem("id")

    Dim childRecords As Long
    childRecords = details.Repository.GetAll.WhereFieldEquals("CustomerGroupId", id).Count

    If childRecords > 0 Then
        MsgBox StringFormat("This item has {0} item(s) associated to it,\nit cannot be deleted.", childRecords), vbExclamation, "Attention!"
        Exit Sub
    End If

    If RequestUserConfirmation(StringFormat("Delete item #{0}?\n(this cannot be undone!)", id)) Then
        Repository.Remove id
        Refresh
    End If

End Sub

Public Sub ExecuteEditCommand()

    Dim id As Long
    id = View.SelectedItem("id")

    Dim description As String
    If Not RequestUserInput(prompt:=StringFormat("Please enter a new description for the CustomerGroup ID#{0}:", id), _
                            title:="Edit", _
                            outResult:=description, _
                            default:=View.SelectedItem("description")) _
    Then
        Exit Sub
    End If

    Repository.Update id, NewCustomerGroup(id, description)
    Refresh

End Sub

Private Sub IPresenter_ExecuteAddCommand()
    ExecuteAddCommand
End Sub

Private Sub IPresenter_ExecuteCloseCommand()
    ExecuteCloseCommand
End Sub

Private Sub IPresenter_ExecuteDeleteCommand()
    ExecuteDeleteCommand
End Sub

Private Sub IPresenter_ExecuteEditCommand()
    ExecuteEditCommand
End Sub

Private Sub IPresenter_ExecuteRefreshCommand()
    ExecuteRefreshCommand
End Sub

Private Property Let IPresenter_MasterId(ByVal value As Long)
'not implemented
End Property

Private Property Get IPresenter_MasterId() As Long
'not implemented
End Property

Private Property Set IPresenter_Repository(ByVal value As IRepository)
    Set Repository = value
End Property

Private Property Get IPresenter_Repository() As IRepository
    Set IPresenter_Repository = Repository
End Property

Private Sub IPresenter_Show()
    Show
End Sub

Private Property Set IPresenter_View(ByVal value As IView)
    Set View = value
End Property

Private Property Get IPresenter_View() As IView
    Set IPresenter_View = View
End Property

This implementation is a "master" presenter, if it were a "details" presenter, the MasterId property would be properly implemented, and the DetailsPresenter might be left out; other implementations may not respond to Add and Delete commands - hence, for each data table I'll want to maintain, I'll have to implement an IPresenter.


Wait, it's localized, too?

In case you're curious about this GetResourceString function that's used in the forms; one of the requirements is to have the application display in English on English systems, and in French on French systems; so I implemented a Resources code module:

Resources code module

Option Explicit
Public Enum Culture
    EN_US = 1033
    EN_UK = 2057
    EN_CA = 4105
    FR_FR = 1036
    FR_CA = 3084
End Enum

Private resourceSheet As Worksheet

Public Sub Initialize()

    Dim languageCode As String

    Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)

        Case Culture.EN_CA, Culture.EN_UK, Culture.EN_US:
            languageCode = "EN"

        Case Culture.FR_CA, Culture.FR_FR:
            languageCode = "FR"

        Case Else:
            languageCode = "EN"

    End Select

    Set resourceSheet = Worksheets("Resources." & languageCode)

End Sub

Public Function GetResourceString(ByVal resourceName As String) As String

    Dim resxTable As ListObject
    If resourceSheet Is Nothing Then Initialize
    Set resxTable = resourceSheet.ListObjects(1)

    Dim i As Long
    For i = 1 To resxTable.ListRows.Count
        Dim lookup As String
        lookup = resxTable.Range(i + 1, 1)
        If lookup = resourceName Then
            GetResourceString = resxTable.Range(i + 1, 2)
            Exit Function
        End If
    Next

End Function

That's right: I'm hiding two worksheets in that workbook, named Resources.EN and Resources.FR and each containing a table (ListObject) that contains English and French string resources:

SimpleView with English resources SimpleView with French resources

\$\endgroup\$
  • 5
    \$\begingroup\$ "The problem is that Implements doesn't support events." <--- this :'( \$\endgroup\$ – Blackhawk Nov 6 '14 at 14:23
6
\$\begingroup\$

There's usually very little I can say about your code, but maybe if I just start going down line by line I'll find something. I'm hoping someone else who knows more about and come along as well.

Simple Form

  • I don't see Types uses very often in . Normally when I do, what is really needed is a class. I don't think that's the case here, but if ViewModel changes down the road, it's not hard to switch.
  • I think Selection would be less ambiguous as SelectedRow.
  • Ummmm........ vm..... I know VB being case insensitive sucks, but couldn't you have at least dsmvwld it? I bet you were avoiding (gasp) hungarian notation. Given the choice between vm and vwModel, I'll take the dsmvwld hngNotation.
  • I would probably use a couple of constants in UserForm_Initialize over Me.Height and Me.Width. It's too easy to change it accidentally in design mode.
  • BindControlLayout looks good. I like the use of bitwise enumeration.
  • UserForm_Resize Needs to have an error handler. Anytime you turn screen updating off, you'll need an error handler. Just in case.
  • Okay, now I see why you went with vm and Selection. The user form has properties Model and SelectedItem. Naming is hard in vb. You could still use SelectedItem for the ViewModel Type though. I don't think it would cause any confusion.
  • The localization is really frickin' cool. Seriously. That's cool. But, you've now bound the code to this specific workbook. What if you want to reuse this somewhere else? You're this far down the rabbit hole, why not create an interface that implements a dicitonary? I'm pretty sure I remember reading somewhere that you can leverage .Net's dictionary if the framework is installed on your users machines. (Hint: The .Net framework is installed on practically every windows machine.)
  • All of the Click events have to check If vm.Callback.CallbackOwner Is Nothing. There's some duplication here, but I don't feel it's a big deal. You might consider creating a boolean function, but that might be overkill. (cough-cough it is cough-cough)

Ok, so I only touched on the "Simple Form" (and just a bit on resources), but I suspect I could only give more of the same kind of advice. So, I'll leave the rest of the code for someone else.

\$\endgroup\$
  • \$\begingroup\$ The code is actually tied to an Excel workbook anyway; I could export the form and import it in another VBA project, localization will work as long as there's a [Resources.EN] worksheet. I used a private type to help a bit with naming clashes.. but yeah, naming is hard, especially in a case-insensitive language! Nice review! :) \$\endgroup\$ – Mathieu Guindon Jul 29 '14 at 23:02
  • \$\begingroup\$ That's a really good point. I hadn't thought about that. In that case you should take some precautions. You wouldn't want an ambitious user making their way into those hidden sheets. Password protect the workbook maybe? In Access I'd "compile" the project into an *.accde file. I don't know what options there are for Excel. (Thanks btw. Cool project.) \$\endgroup\$ – RubberDuck Jul 29 '14 at 23:07
4
\$\begingroup\$

There's an itchy spot with extensibility: because an implementing class must implement all members of the IPresenter interface, adding new commands is quickly becoming a painful experience.

Say you have a view that has a MoveUpButton and a MoveDownButton. With the way it is right now, you'll have to add 4 methods to the IPresenter interface, and modify every single existing implementation accordingly, even if the other implementations don't need to implement these methods.

Instead of having ExecuteXxxxxxCommand and CanExecuteXxxxxxCommand methods for every command, design interfaces so as to avoid ever having to modify it in the future:

Public Sub ExecuteCommand(ByVal commandId As CommandType)
End Sub

Public Function CanExecuteCommand(ByVal commandId As CommandType) As Boolean
End Function

By passing in a CommandType enum parameter, you can now easily extend the design (by simply adding a new enum value for the new command) and add new commands without having to modify the IPresenter interface.

\$\endgroup\$

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.