Following-up on this post where I implemented a Repository Pattern in vba to abstract ADODB and enable testing my Excel app without hitting a database backend; curious about how far vba would let me push inversion-of-control 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.
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 vba 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:
Implementsdoesn't support events." <--- this :'( \$\endgroup\$