13
\$\begingroup\$

Following-up on this post, I wanted to be able to put a copy of that Excel workbook on a USB key and take it home to keep working on the code a bit (there's more than just one or two tables to maintain, so I'll have about a dozen forms when I'm done)... but to be able to test every functionality of my CRUD app without actually hitting the database, I had to get the abstraction level much higher than the typical "macro". Guess what abstraction first came to my mind.

(comments added for reviewers' convenience, they're not in the actual code)

IRepository class module

Option Explicit

Public Function GetById(ByVal id As Long) As SqlResultRow
    'because, all my tables have an Id primary key.
End Function

Public Function GetAll() As SqlResult
End Function

Public Function Count() As Long
End Function

Public Sub Add(ByVal value As SqlResultRow)
End Sub

Public Sub Remove(ByVal id As Long)
End Sub

Public Sub Update(ByVal id As Long, ByVal value As SqlResultRow)
End Sub

Public Function NewItem(ByVal model As SqlResult, ByVal values As Dictionary) As SqlResultRow
    'creates a new item, out of a Scripting.Dictionary containing field names & values.
    'model: contains the field names.
    'values: field names as key, field values for values.
End Function

Before going directly into an implementation of that interface, you need to know a little bit about the classes involved here, if you haven't seen this post (Materializing any ADODB Query) and this post (Creating ADODB Parameters on the fly), they're the foundation that led to this.

About SqlResult & SqlResultRow

All QuickXxxxx methods in the SqlCommand class iterate and consume the ADODB recordset, and take care of opening/closing the connections and the recordset. Because the results have already been iterated when the method returns, the data ends up iterated twice - once in SqlCommand (iterating the recordset), and once in the client code (iterating the DTO's). It's a tradeoff for abstraction and readability, and works very well with smaller datasets. For larger results the class exposes an equivalent API that lets the client deal with the connection, and returns an ADODB.Recordset.

SqlResultRow

The SqlResultRow class is essentially a generic DTO that allows accessing its values by index or by name, like this:

Dim description As String
description = row("description")

The value obtained keeps its type, so if the database has Description (the indexer Item default property is not not case-sensitive) as a VARCHAR(50), then TypeName(row("description")) returns String.

SqlResult

This class encapsulates a List (code here) of SqlResultRow objects, and knows about the column names. Its NewEnum member has a special attribute that makes the type work with a For Each loop, so client code can do this:

sql = "SELECT Foo, DateInserted FROM FooBar WHERE DateInserted > ?;"
Set result = cmd.QuickExecute(sql, Now - 30)
For Each row In result
    Debug.Print row.ToString ' prints a CSV list of the row's values
Next

The delimiter used by ToString is configurable: setting result.ValueSeparator = "|" before entering the loop will cause all rows to use | as a delimiter. If it's not specified, it defaults to a comma.


Enough talk context, here's an implementation:

CustomerGroupRepository class module

Option Explicit
Private cmd As New SqlCommand
Implements IRepository

Public Function NewItem(ByVal model As SqlResult, ByVal values As Dictionary) As SqlResultRow

    Dim result As New SqlResultRow

    Dim items() As String
    ReDim items(LBound(values.items) To UBound(values.items))

    Dim i As Integer
    For i = LBound(values.items) To UBound(values.items)
        items(i) = values.items(i)
    Next

    Set NewItem = result.Mock(model, items)

End Function

Public Sub Add(ByVal value As SqlResultRow)

    Dim sql As String
    sql = "INSERT INTO Planning.CustomerGroups (Description, DateInserted) VALUES (?, ?);"

    cmd.QuickExecuteNonQuery sql, value("description"), Now

End Sub

Public Function GetAll() As SqlResult

    Dim sql As String
    sql = "SELECT Id, Description FROM Planning.CustomerGroups ORDER BY Id;"

    Set GetAll = cmd.QuickExecute(sql)

End Function

Public Function GetById(ByVal id As Long) As SqlResultRow

    Dim sql As String
    sql = "SELECT Id, Description FROM Planning.CustomerGroups WHERE Id = ?;"

    Set GetById = cmd.QuickSelectFirstRow(sql, id)

End Function

Public Sub Remove(ByVal id As Long)

    Dim sql As String
    sql = "DELETE FROM Planning.CustomerGroups WHERE Id = ?;"

    cmd.QuickExecuteNonQuery sql, id

End Sub

Public Sub Update(ByVal id As Long, ByVal value As SqlResultRow)

    Dim sql As String
    sql = "UPDATE Planning.CustomerGroups SET Description = ?, DateUpdated = ? WHERE Id = ?;"

    cmd.QuickExecuteNonQuery sql, value("description"), Now, value("id")

End Sub

Public Function Count() As Long

    Dim sql As String
    sql = "SELECT COUNT(*) FROM Planning.CustomerGroups;"

    Count = cmd.QuickSelectSingleValue(sql)

End Function

Private Sub IRepository_Add(ByVal value As SqlResultRow)
    Add value
End Sub

Private Function IRepository_Count() As Long
    IRepository_Count = Count
End Function

Private Function IRepository_GetAll() As SqlResult
    Set IRepository_GetAll = GetAll
End Function

Private Function IRepository_GetById(ByVal id As Long) As SqlResultRow
    Set IRepository_GetById = GetById(id)
End Function

Private Function IRepository_NewItem(ByVal model As SqlResult, ByVal values As Scripting.IDictionary) As SqlResultRow
    Set IRepository_NewItem = NewItem(model, values)
End Function

Private Sub IRepository_Remove(ByVal id As Long)
    Remove id
End Sub

Private Sub IRepository_Update(ByVal id As Long, ByVal value As SqlResultRow)
    Update id, value
End Sub

MockRepository class module

By property-injecting a mock implementation of this IRepository interface into a Presenter, I can run the UI and test every feature, without hitting the database - and I can work offline on implementing the other features.

Here's the mock implementation in question:

Option Explicit
Private FieldNames As List
Private Items As List
Implements IRepository
Implements IStringRepresentable

Public Sub SetModel(model As SqlResult)

    Set FieldNames = model.FieldNames
    Set Items = New List

    Dim row As SqlResultRow
    For Each row In model
        Items.Add row
    Next

End Sub

Private Function MockSqlResult() As SqlResult

    Dim result As New SqlResult

    Dim name As Variant
    For Each name In FieldNames
        result.AddFieldName name
    Next

    Dim row As SqlResultRow
    For Each row In Items
        result.AddValue row
    Next

    Set MockSqlResult = result

End Function

Public Function Create(model As SqlResult) As MockRepository

    Dim result As New MockRepository
    result.SetModel model

    Set Create = result

End Function

Public Sub Add(ByVal value As SqlResultRow)

    Dim newId As Long
    newId = Items.Count + 1
    If Items.Last("id") <= newId Then
        newId = Items.Last("id") + 1
    End If

    value("id") = newId
    Items.Add value

End Sub

Public Function GetAll() As SqlResult
    Set GetAll = MockSqlResult
End Function

Public Function GetById(ByVal id As Long) As SqlResultRow
    Set GetById = Items(id)
    Dim row As SqlResultRow
    For Each row In Items
        If row("id") = id Then
            Set GetById = row
            Exit Function
        End If
    Next
End Function

Public Sub Remove(ByVal id As Long)
    Items.Remove GetById(id)
End Sub

Public Sub Update(ByVal id As Long, ByVal value As SqlResultRow)

    Dim row As SqlResultRow
    Set row = GetById(id)

    Dim i As Integer
    For i = 1 To value.FieldCount
        If LCase(FieldNames(i)) <> "id" Then
            row(i - 1) = value(i - 1)
        End If
    Next

End Sub

Public Function Count() As Long
    Count = Items.Count
End Function

Public Function NewItem(ByVal values As Dictionary) As SqlResultRow

    Dim result As New SqlResultRow
    Dim i As Integer

    Dim model As New SqlResult
    For i = LBound(values.Keys) To UBound(values.Keys)
        model.AddFieldName values.Keys(i)
    Next

    For i = LBound(values.Items) To UBound(values.Items)
        result.AddValue values.Items(i)
    Next

    Set result.ParentResult = model
    Set NewItem = result

End Function

Public Function ToString() As String
    Dim result As String

    Dim Item As IStringRepresentable
    For Each Item In Items
        result = result & Item.ToString & vbNewLine
    Next

    ToString = result
End Function

Private Sub IRepository_Add(ByVal value As SqlResultRow)
    Add value
End Sub

Private Function IRepository_Count() As Long
    IRepository_Count = Count
End Function

Private Function IRepository_GetAll() As SqlResult
    Set IRepository_GetAll = GetAll
End Function

Private Function IRepository_GetById(ByVal id As Long) As SqlResultRow
    Set IRepository_GetById = Items(id)
End Function

Private Sub IRepository_Remove(ByVal id As Long)
    Remove id
End Sub

Private Sub IRepository_Update(ByVal id As Long, ByVal value As SqlResultRow)
    Update id, value
End Sub

Private Function IRepository_NewItem(ByVal model As SqlResult, ByVal values As Dictionary) As SqlResultRow
    Set IRepository_NewItem = NewItem(values)
End Function

Private Function IStringRepresentable_ToString() As String
    IStringRepresentable_ToString = ToString
End Function

Writing the above allowed me to write a TestModule that would bring up the UI and behave the same as with the MySQL backend - the idea isn't to write unit tests, it's just to be able to test/run it without the database, and it works like this:

TestModule code module

Option Explicit

Public Sub TestMaintainCustomerGroups()

    Dim CustomerGroups As New MockRepository
    Set CustomerGroups = CustomerGroups.Create(GetMockCustomerGroupsModel)

    Dim Customers As New MockRepository
    Set Customers = Customers.Create(GetMockCustomersModel)

    Dim presenter As New CustomerGroupsPresenter
    Set presenter.CustomerGroupsRepo = CustomerGroups
    Set presenter.CustomersRepo = Customers

    presenter.Show

End Sub

Private Function GetMockCustomerGroupsModel() As SqlResult

    Dim model As New SqlResult
    model.AddFieldName "Id"
    model.AddFieldName "Description"

    Dim row As SqlResultRow
    Dim i As Integer
    For i = 1 To 10

        Set row = New SqlResultRow
        Set row.ParentResult = model

        row.AddValue i
        row.AddValue "Test" & i

        model.AddValue row

    Next

    Set GetMockCustomerGroupsModel = model

End Function

Private Function GetMockCustomersModel() As SqlResult

    Dim model As New SqlResult
    model.AddFieldName "Id"
    model.AddFieldName "Code"
    model.AddFieldName "Name"
    model.AddFieldName "CustomerGroupId"

    Dim row As SqlResultRow
    Dim i As Integer
    For i = 1 To 10

        Set row = New SqlResultRow
        Set row.ParentResult = model

        row.AddValue i
        row.AddValue 1000 + i
        row.AddValue "Customer" & i
        row.AddValue 1

        model.AddValue row

    Next

    Set GetMockCustomersModel = model

End Function

I think we can call this in !

\$\endgroup\$
  • \$\begingroup\$ Did you have any particular concerns about the code? \$\endgroup\$ – RubberDuck Jul 24 '14 at 16:37
  • \$\begingroup\$ @ckuhn203 Not really, I think this is probably the best OOP-like VBA code I've ever written ;) ...just asking for a peer review / criticism, all comments welcome! \$\endgroup\$ – Mathieu Guindon Jul 24 '14 at 16:39
8
\$\begingroup\$

I think this is pretty much done. You have great naming. No glaring bugs as far as I can tell. It's clear and concise. Very OOP, which is impressive given the language. Even the high level design seems pretty darn tight. (I know very little about dependency injection though. I could have missed something that would be obvious to someone else.)

I just can't find anything to pick apart. Well done. Thank you for helping me make the case that VBA is a legitimate programming language in the right hands.

\$\endgroup\$
  • 4
    \$\begingroup\$ Ok, now post a selfie and prove me wrong. \$\endgroup\$ – RubberDuck Jul 24 '14 at 17:11
  • 3
    \$\begingroup\$ "legitimate hands" - you and him, huh? \$\endgroup\$ – Vogel612 Jul 24 '14 at 17:14
  • \$\begingroup\$ Nah. Just himm @Vogel612. I'm a just a hack getting the job done. \$\endgroup\$ – RubberDuck Jul 24 '14 at 17:58
  • 2
    \$\begingroup\$ ...but that would be overkill IMO. Unless you say "we've come this far, might as well go all the way down the rabbit hole"... \$\endgroup\$ – Mathieu Guindon Jul 24 '14 at 19:20
  • 3
    \$\begingroup\$ I said that doing this was overkill. Go ahead and see how far down the rabbit hole goes. =;)- \$\endgroup\$ – RubberDuck Jul 24 '14 at 19:31
8
\$\begingroup\$

The NewItem implementation in the CustomerGroupsRepository has something weird going on:

Set NewItem = result.Mock(model, items)

Why add a Mock method to the SqlResultRow type? The SqlResultRow worked fine before, it shouldn't have been modified to accomodate the IRepository implementations. In fact, the NewItem implementation could be written like this:

Public Function NewItem(ByVal model As SqlResult, ByVal values As Dictionary) As SqlResultRow

    Dim result As New SqlResultRow
    Set result.ParentResult = model

    Dim Items() As String
    ReDim Items(LBound(values.Items) To UBound(values.Items))

    Dim i As Integer
    For i = LBound(values.Items) To UBound(values.Items)
        Items(i) = values.Items(i)
    Next

    Set NewItem = result

End Function

Also the name CustomerGroupsRepository isn't ideal, it should be CustomerGroupRepository.

The IStringRepresentable interface is just metadata, it brings nothing really useful to the table - the story would be different if inheritance and polymorphism were supported by the language though, so this:

Dim Item As IStringRepresentable
For Each Item In Items
    result = result & Item.ToString & vbNewLine
Next

Is a useless abstraction, since it is already known that Items is a List<SqlResultRow>: the class is already coupled with SqlResultRow, so IStringRepresentable isn't buying anything.

Rest looks [very] good to me.

\$\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.