Free body diagram generator using MVP for VBA

Question

Based on my understanding of Model View Presenter (MVP) I have it generate a diagram. Is this a correct implementation of MVP?

What deficiencies are there in my implementation?

UI

enter image description here

Generated diagram

enter image description here

---

The code

'LoadingModule class
'@Folder("Model")
Option Explicit
Private Type THelper
 PointLoads As Long
 DistributedLoads As Long
 LeftSupport As BoundaryCondition
 RightSupport As BoundaryCondition
 SpanCondition As SpanType
End Type
Private this As THelper
Public Property Get PointLoadsCount() As Long
 PointLoadsCount = this.PointLoads
End Property
Public Property Let PointLoadsCount(ByVal value As Long)
 this.PointLoads = value
End Property
Public Property Get DistributedLoadsCount() As Long
 DistributedLoadsCount = this.DistributedLoads
End Property
Public Property Let DistributedLoadsCount(ByVal value As Long)
 this.DistributedLoads = value
End Property
Public Property Get LeftBoundaryCondition() As BoundaryCondition
 LeftBoundaryCondition = this.LeftSupport
End Property
Public Property Let LeftBoundaryCondition(ByVal value As BoundaryCondition)
 this.LeftSupport = value
End Property
Public Property Get RightBoundaryCondition() As BoundaryCondition
 RightBoundaryCondition = this.RightSupport
End Property
Public Property Let RightBoundaryCondition(ByVal value As BoundaryCondition)
 this.RightSupport = value
End Property
Public Property Get Self() As LoadingModel
 Set Self = Me
End Property
Private Sub Class_Initialize()
 this.PointLoads = 0
 this.DistributedLoads = 0
 this.LeftSupport = BoundaryCondition.Fixed
 this.RightSupport = BoundaryCondition.Fixed
 this.SpanCondition = SpanType.Simple
End Sub
Public Property Get SpanCondition() As SpanType
 SpanCondition = this.SpanCondition
End Property
Public Property Let SpanCondition(ByVal value As SpanType)
 this.SpanCondition = value
End Property

'IView Interface
'@Folder("Abstractions")
'@Interface
Option Explicit
Public Function ShowDialog(ByVal viewModel As Object) As Boolean
End Function

'Userform
'@Folder("UI")
Option Explicit
Implements IView
Private lastPointLoadValue As Long
Private lastDistributedLoadValue As Long
Private Const NumericInputsOnly As String = "Only numeric inputs allowed"
Private Type TView
 IsCancelled As Boolean
 model As VBAProject.LoadingModel
End Type
Private this As TView
Public Property Get model() As LoadingModel
 Set model = this.model
End Property
Public Property Let model(ByVal value As LoadingModel)
 Set this.model = value
End Property
Public Property Get IsCancelled() As Boolean
 IsCancelled = this.IsCancelled
End Property
Private Sub CancelButton_Click()
 OnCancel
End Sub
Private Function IView_ShowDialog(ByVal viewModel As Object) As Boolean
 Set this.model = viewModel
 SyncUIWithModel
 Me.Show
 IView_ShowDialog = Not this.IsCancelled
End Function
Private Sub SyncUIWithModel()
 Dim spanCounter As Long
 For spanCounter = 0 To SpanTypeListBox.ListCount - 1
 If (SpanTypeListBox.List(spanCounter) = SpanConditionConverter.ToString(this.model.SpanCondition)) Then
 SpanTypeListBox.ListIndex = spanCounter
 Exit For
 End If
 Next
 If model.SpanCondition = Cantilever Then
 model.LeftBoundaryCondition = Fixed
 model.RightBoundaryCondition = Free
 End If
 Dim leftCounter As Long
 For leftCounter = 0 To LeftSupportTypeListBox.ListCount - 1
 If (LeftSupportTypeListBox.List(leftCounter) = SupportTypeConverter.ToString(this.model.LeftBoundaryCondition)) Then
 LeftSupportTypeListBox.ListIndex = leftCounter
 Exit For
 End If
 Next
 Dim rightCounter As Long
 For rightCounter = 0 To RightSupportTypeListBox.ListCount - 1
 If (RightSupportTypeListBox.List(rightCounter) = SupportTypeConverter.ToString(this.model.RightBoundaryCondition)) Then
 RightSupportTypeListBox.ListIndex = rightCounter
 Exit For
 End If
 Next
End Sub
Private Sub OKButton_Click()
 Me.Hide
End Sub
Private Sub OnCancel()
 this.IsCancelled = True
 Me.Hide
End Sub
Private Sub SpanTypeListBox_Click()
 If Not this.model Is Nothing Then
 this.model.SpanCondition = SpanConditionConverter.ToEnum(SpanTypeListBox.List(SpanTypeListBox.ListIndex))
 End If
 If this.model.SpanCondition = Cantilever Then
 MsgBox "Don't forget to mark the right boundary condition as free."
 End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 If CloseMode = VbQueryClose.vbFormControlMenu Then
 Cancel = True
 OnCancel
 End If
End Sub
Private Sub LeftSupportTypeListBox_Change()
' viewModel.LeftSupport = SupportTypeConverter.ToEnum(LeftSupportTypeListBox.value)
 ' ^ Errors out | v workaround
 If Not this.model Is Nothing Then
 this.model.LeftBoundaryCondition = SupportTypeConverter.ToEnum(LeftSupportTypeListBox.List(LeftSupportTypeListBox.ListIndex))
 End If
End Sub
Private Sub RightSupportTypeListBox_Change()
' viewModel.RightSupport = SupportTypeConverter.ToEnum(RightSupportTypeListBox.value)
 If Not this.model Is Nothing Then
 this.model.RightBoundaryCondition = SupportTypeConverter.ToEnum(RightSupportTypeListBox.List(RightSupportTypeListBox.ListIndex))
 End If
End Sub
Private Sub UserForm_Initialize()
 LeftSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Fixed), 0
 LeftSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Pinned), 1
 LeftSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Roller), 2
 LeftSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Free), 3
 LeftSupportTypeListBox.SetFocus
 RightSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Fixed), 0
 RightSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Pinned), 1
 RightSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Roller), 2
 RightSupportTypeListBox.AddItem SupportTypeConverter.ToString(BoundaryCondition.Free), 3
 SpanTypeListBox.AddItem SpanConditionConverter.ToString(SpanType.Simple), 0
 SpanTypeListBox.AddItem SpanConditionConverter.ToString(SpanType.Cantilever), 1
 PointLoadsSpinButton.value = 0
 PointLoadsTextBox.value = PointLoadsSpinButton.value
 DistributedLoadsSpinButton.value = 0
 DistributedLoadsTextBox.value = DistributedLoadsSpinButton.value
End Sub
Private Sub PointLoadsSpinButton_Change()
 PointLoadsTextBox.value = PointLoadsSpinButton.value
 lastPointLoadValue = PointLoadsSpinButton.value
End Sub
Private Sub PointLoadsTextBox_Change()
 If PointLoadsTextBox = vbNullString Then
 PointLoadsTextBox.value = 0
 End If
 If Not IsNumeric(PointLoadsTextBox.value) Then
 PointLoadsTextBox.value = lastPointLoadValue
 MsgBox NumericInputsOnly
 Exit Sub
 End If
 PointLoadsSpinButton.value = PointLoadsTextBox.value
 If Not this.model Is Nothing Then
 this.model.PointLoadsCount = PointLoadsTextBox.value
 End If
End Sub
Private Sub DistributedLoadsSpinButton_Change()
 DistributedLoadsTextBox.value = DistributedLoadsSpinButton.value
 lastDistributedLoadValue = DistributedLoadsSpinButton.value
End Sub
Private Sub DistributedLoadsTextBox_Change()
 If DistributedLoadsTextBox.value = vbNullString Then
 DistributedLoadsTextBox.value = 0
 End If
 If Not IsNumeric(DistributedLoadsTextBox.value) Then
 DistributedLoadsTextBox.value = lastDistributedLoadValue
 MsgBox NumericInputsOnly
 Exit Sub
 End If
 DistributedLoadsSpinButton.value = DistributedLoadsTextBox.value
 If Not this.model Is Nothing Then
 this.model.DistributedLoadsCount = CLng(DistributedLoadsTextBox.value)
 End If
End Sub

'Presenter module
Option Explicit
Private ws As Worksheet
Private Const defaultSupportDimension As Long = 10
Private Const defaultSpanWidth As Double = 300
Public Sub CreateLoadingDiagram()
 Dim view As IView
 Set view = New BasicView
 Dim model As LoadingModel
 Set model = New LoadingModel
 If Not view.ShowDialog(model) Then
 Exit Sub
 End If
 Set ws = ActiveSheet
 Dim leftBoundaryConiditionShape As Shape
 Dim topLeftCell As Range
 Set topLeftCell = ActiveWindow.VisibleRange(7, 2)
 Set leftBoundaryConiditionShape = CreateBoundaryConditionShape( _
 model.LeftBoundaryCondition, _
 topLeftCell.Left, _
 topLeftCell.Top)
 Dim spanWidth As Double
 If (model.SpanCondition = Simple) Then
 spanWidth = defaultSpanWidth
 Else
 spanWidth = defaultSpanWidth / 2
 End If
 Dim rightBoundaryConditionShape As Shape
 Set rightBoundaryConditionShape = CreateBoundaryConditionShape( _
 model.RightBoundaryCondition, _
 topLeftCell.Left - defaultSupportDimension / 2 + spanWidth, _
 topLeftCell.Top)
 Dim beamMember As Shape
 Set beamMember = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 topLeftCell.Left + defaultSupportDimension / 2, _
 topLeftCell.Top, _
 topLeftCell.Left + defaultSpanWidth, _
 topLeftCell.Top)
 Dim distributedLoadHeightOffset As Long
 AddDistributedLoads model.DistributedLoadsCount, _
 beamMember, _
 topLeftCell, _
 distributedLoadHeightOffset
 '@Ignore UnassignedVariableUsage
 AddPointLoads model.PointLoadsCount, beamMember, distributedLoadHeightOffset
 Set ws = Nothing
End Sub
Private Function CreateBoundaryConditionShape(ByVal condition As BoundaryCondition, ByVal leftEdge As Double, ByVal topEdge As Double) As Shape
 If condition = Free Then
 Exit Function
 End If
 If condition = Fixed Then
 Set CreateBoundaryConditionShape = CreateFixedBoundaryConditionShape(leftEdge, topEdge)
 Exit Function
 End If
 Dim shapeType As MsoAutoShapeType
 If condition = Pinned Then
 shapeType = MsoAutoShapeType.msoShapeIsoscelesTriangle
 ElseIf condition = Roller Then
 shapeType = MsoAutoShapeType.msoShapeOval
 End If
 Set CreateBoundaryConditionShape = ws.Shapes.AddShape(shapeType, _
 leftEdge, _
 topEdge, _
 defaultSupportDimension, _
 defaultSupportDimension)
End Function
Private Function CreateFixedBoundaryConditionShape(ByVal leftEdge As Double, ByVal topEdge As Double) As Shape
 Dim horizon As Shape
 Set horizon = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 leftEdge, _
 topEdge, _
 leftEdge + defaultSupportDimension, _
 topEdge)
 Dim slanted1 As Shape
 Set slanted1 = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 leftEdge, _
 topEdge + 0.5 * defaultSupportDimension, _
 leftEdge + 0.5 * defaultSupportDimension, _
 topEdge)
 Dim slanted2 As Shape
 Set slanted2 = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 leftEdge, _
 topEdge + 1 * defaultSupportDimension, _
 leftEdge + 1 * defaultSupportDimension, _
 topEdge)
 Dim slanted3 As Shape
 Set slanted3 = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 leftEdge + 0.5 * defaultSupportDimension, _
 topEdge + 1 * defaultSupportDimension, _
 leftEdge + 1 * defaultSupportDimension, _
 topEdge + 0.5 * defaultSupportDimension)
 Set CreateFixedBoundaryConditionShape = ws.Shapes.Range(Array(horizon.Name, slanted1.Name, slanted2.Name, slanted3.Name)).Group
End Function
Private Sub AddDistributedLoads(ByVal nuberOfDistributedLoads As Long, ByVal beamMemberShape As Shape, ByVal topLeftCell As Range, ByRef outDistributedLoadHeightOffset As Long)
 Const distributedLoadHeight As Long = 30
 Dim counter As Long
 For counter = 1 To nuberOfDistributedLoads
 outDistributedLoadHeightOffset = counter * distributedLoadHeight
 Dim distributedLoad As Shape
 Set distributedLoad = ws.Shapes.AddShape(MsoAutoShapeType.msoShapeRectangle, _
 topLeftCell.Left + defaultSupportDimension / 2, _
 topLeftCell.Top - outDistributedLoadHeightOffset, _
 beamMemberShape.Width, _
 distributedLoadHeight)
 distributedLoad.Fill.Visible = msoFalse
 Next
End Sub
Private Sub AddPointLoads(ByVal numberOfPointLoads As Long, ByVal beamMember As Shape, ByVal distributedLoadHeightOffset As Long)
 Dim leftDisplacement As Double
 leftDisplacement = beamMember.Width / (1 + numberOfPointLoads)
 Dim counter As Long
 For counter = 1 To numberOfPointLoads
 Dim pointLoadInsertion As Double
 pointLoadInsertion = beamMember.Left + (leftDisplacement * counter)
 Dim pointLoad As Shape
 Set pointLoad = ws.Shapes.AddConnector(MsoConnectorType.msoConnectorStraight, _
 pointLoadInsertion, _
 beamMember.Top - 50 - distributedLoadHeightOffset, _
 pointLoadInsertion, _
 beamMember.Top - distributedLoadHeightOffset)
 pointLoad.Line.EndArrowheadStyle = MsoArrowheadStyle.msoArrowheadTriangle
 Next
End Sub

Converters are used to allow using Enums instead of strings to maintain consistency and avoid global variables. They have the VB_PredeclaredId attribute set to True.

'@PredeclaredId
'@Folder("Converters")
Option Explicit
Public Enum SpanType
 NotSet
 Simple
 Cantilever
End Enum
Private StringForEnum As Dictionary
Private EnumForString As Dictionary
Private Sub Class_Initialize()
 PopulateDictionaries
End Sub
Private Sub PopulateDictionaries()
 Set EnumForString = New Dictionary
 EnumForString.CompareMode = TextCompare
 EnumForString.Add "Simple", SpanType.Simple
 EnumForString.Add "Cantilever", SpanType.Cantilever
 Set StringForEnum = New Dictionary
 EnumForString.CompareMode = TextCompare
 Dim key As Variant
 For Each key In EnumForString.Keys
 StringForEnum.Add EnumForString.Item(key), key
 Next
End Sub
Public Function ToEnum(ByVal value As String) As SpanType
 If Not EnumForString.Exists(value) Then
 ThrowInvalidArgument "ToEnum", value
 End If
 ToEnum = EnumForString(value)
End Function
Public Function ToString(ByVal value As SpanType) As String
 If Not StringForEnum.Exists(value) Then
 ThrowInvalidArgument "ToString", CStr(value)
 End If
 ToString = StringForEnum(value)
End Function
Private Sub ThrowInvalidArgument(ByVal source As String, ByVal value As String)
 Err.Raise 5, Information.TypeName(Me) & "." & source, "Invalid input '" & value & "' was supplied."
End Sub
Public Property Get Enums() As Variant
 Enums = EnumForString.Items
End Property
Public Property Get Strings() As Variant
 Strings = EnumForString.Keys
End Property

'@PredeclaredId
'@Folder("Converters")
Option Explicit
Public Enum BoundaryCondition
 NotSet
 Fixed
 Pinned
 Roller
 Free
End Enum
Private StringForEnum As Dictionary
Private EnumForString As Dictionary
Private Sub Class_Initialize()
 PopulateDictionaries
End Sub
Private Sub PopulateDictionaries()
 Set EnumForString = New Dictionary
 EnumForString.CompareMode = TextCompare
 EnumForString.Add "Fixed", BoundaryCondition.Fixed
 EnumForString.Add "Pinned", BoundaryCondition.Pinned
 EnumForString.Add "Roller", BoundaryCondition.Roller
 EnumForString.Add "Free", BoundaryCondition.Free
 Set StringForEnum = New Dictionary
 EnumForString.CompareMode = TextCompare
 Dim key As Variant
 For Each key In EnumForString.Keys
 StringForEnum.Add EnumForString.Item(key), key
 Next
End Sub
Public Function ToEnum(ByVal value As String) As BoundaryCondition
 If Not EnumForString.Exists(value) Then
 ThrowInvalidArgument "ToEnum", value
 End If
 ToEnum = EnumForString(value)
End Function
Public Function ToString(ByVal value As BoundaryCondition) As String
 If Not StringForEnum.Exists(value) Then
 ThrowInvalidArgument "ToString", CStr(value)
 End If
 ToString = StringForEnum(value)
End Function
Private Sub ThrowInvalidArgument(ByVal source As String, ByVal value As String)
 Err.Raise 5, Information.TypeName(Me) & "." & source, "Invalid input '" & value & "' was supplied."
End Sub
Public Property Get Enums() As Variant
 Enums = EnumForString.Items
End Property
Public Property Get Strings() As Variant
 Strings = EnumForString.Keys
End Property

• PeterT: Very nice implementation. There is very little I would change, and then it would likely be more as personal preferences. For example, I've tended to define a single source for all the Enum declarations and converters in a module instead of a persistent class. In that module, I'll often include a central list of custom error codes and descriptions to ensure consistency of numbering across the app. These aren't nits at all, more stylistic differences. Good work.

Answer 1

Amazing work! As PeterT mentioned very little to change in your code, however with that said I did notice some code that keeps repeating itself, not sure if this is intentional.

Checking if the Model is null

If Not this.model Is Nothing Then, this code appears 6 times through out the UserForm, I believe you can validate if the model is null in your IView_ShowDialog procedure, right before you sync the model with the UI, execution will stop if the viewModel is not set.

Private Function IView_ShowDialog(ByVal viewModel As Object) As Boolean
If viewModel Is Nothing Then Exit Function 'exits if viewModel is null
Set this.model = viewModel
SyncUIWithModel
Me.Show
IView_ShowDialog = Not this.IsCancelled
End Function

Public Properties

You are declaring a Public Property Get PointLoadsCount but have a PointLoads private variable under THelper. Why not just use PointLoadsCount, you'll have less naming and less variables to manage, plus it looks cleaner and makes more sense when using this keyword. This is just personal preference, but I do find it easier to manage.

Private Type THelper
 PointLoadsCount As Long
End Type
Private this As THelper
Public Property Get PointLoadsCount() As Long
 PointLoadsCount = this.PointLoadsCount 'renamed to match Private varaible
End Property

Last note, I believe you can eliminate the following line of code, as you are already setting the model, right before you show the form, additionally this would throw a Runtime Error if executed.

Public Property Let model(ByVal value As LoadingModel)'should be a Set not Let 
 Set this.model = value
End Property

Overall excellent implementation, especially with your Enum converters!