1
\$\begingroup\$

ContactEditor uses Excel VBA as a prototyping platform for a personal information manager combining the "Model, View, Presenter" (MVP) pattern and a persistent storage manager.

Fig. 1. Data manager application

FigDataManagerApp

The design of the MVP part follows the ideas/tutorials/code from the RubberDuck VBA blog and demos. The database contains a single table filled with mock contact data. The GUI has one user form that presents a single record data to the user. The "MVP⇔DB" functionality is implemented as a storage library with a pluggable architecture.

Figure 2. DataTable class diagram

FigDataTable

The storage library contains two data model classes: DataTableModel and DataRecordModel. DataTableModel holds a set of rows retrieved from the database (currently, only "SELECT * FROM TABLE_NAME" is supported), and DataRecordModel caches a single record loaded into the user form. Each storage type (such as Excel worksheet or ADODB database) is represented by a single backend class abstracting the storage (e.g., DataRecordWSheet or DataTableADODB) and implementing the associated IDataTableStorage / IDataRecordStorage interface.

From the calling code's perspective, the top-level API object is the data manager (DataTableManager / DataRecordManager) encapsulating a data model instance and an associated backend instance. Additionally, data managers implement IDataTableManager / IDataRecordManager interfaces, and abstract factory classes IDataTableFactory / IDataRecordFactory are also defined as illustrated in Fig. 2 (for the DataTableModel family).

Note, this post only covers the DataTableModel family. Regarding the DataRecordModel family, please see the project documentation. Also, complete source code and tests are available from the project repository.


DataTableModel (model)

'@Folder "ContactEditor.Storage.Table.Model"
'@ModuleDescription "Represents a data table."
'@IgnoreModule ProcedureNotUsed, IndexedDefaultMemberAccess
'@Exposed
Option Explicit


Private Type TDataTableModel
    FieldIndices As Scripting.Dictionary
    IdIndices As Scripting.Dictionary
    DirtyRecords As Scripting.Dictionary
    FieldNames As Variant
    Values As Variant
End Type
Private this As TDataTableModel

Private Sub Class_Initialize()
    Set this.FieldIndices = New Scripting.Dictionary
    this.FieldIndices.CompareMode = TextCompare
    Set this.IdIndices = New Scripting.Dictionary
    this.IdIndices.CompareMode = TextCompare
    Set this.DirtyRecords = New Scripting.Dictionary
    this.DirtyRecords.CompareMode = TextCompare
End Sub

Private Sub Class_Terminate()
    Set this.FieldIndices = Nothing
    Set this.IdIndices = Nothing
    Set this.DirtyRecords = Nothing
End Sub

Public Property Get FieldIndices() As Scripting.Dictionary
    Set FieldIndices = this.FieldIndices
End Property

Public Property Get IdIndices() As Scripting.Dictionary
    Set IdIndices = this.IdIndices
End Property

Public Property Get DirtyRecords() As Scripting.Dictionary
    Set DirtyRecords = this.DirtyRecords
End Property

Public Property Get FieldNames() As Variant
    FieldNames = this.FieldNames
End Property

Public Property Let FieldNames(ByVal FieldNamesArg As Variant)
    this.FieldNames = FieldNamesArg
End Property

Public Property Get Values() As Variant
    Values = this.Values
End Property

Public Property Let Values(ByVal ValuesArg As Variant)
    this.Values = ValuesArg
End Property

Public Property Get IsDirty() As Boolean
    IsDirty = this.DirtyRecords.Count > 0
End Property

Public Function RecordIndexFromId(ByVal RecordId As String) As Long
    RecordIndexFromId = this.IdIndices(RecordId)
End Function

Public Function RecordValuesFromId(ByVal RecordId As String) As Variant
    Dim RecordIndex As Long: RecordIndex = this.IdIndices(RecordId)
    RecordValuesFromId = Application.WorksheetFunction.Index(Values, RecordIndex)
End Function

Public Function FieldIndexFromName(ByVal FieldName As String) As Long
    FieldIndexFromName = this.FieldIndices(FieldName)
End Function

Public Sub IsNotDirty()
    this.DirtyRecords.RemoveAll
End Sub

Public Sub UpdateRecordFromDictionary(ByVal Record As Scripting.Dictionary)
    Const ID_NAME_INDEX As Long = 1
    Dim FieldIdName As String: FieldIdName = this.FieldNames(ID_NAME_INDEX)
    Dim RecordId As String: RecordId = CStr(Record(FieldIdName))
    Dim RecordIndex As Long: RecordIndex = RecordIndexFromId(RecordId)
    this.DirtyRecords(RecordId) = RecordIndex
    
    Dim FieldName As Variant
    Dim FieldIndex As Long
    For Each FieldName In this.FieldNames
        FieldIndex = FieldIndexFromName(FieldName)
        this.Values(RecordIndex, FieldIndex) = Record(CStr(FieldName))
    Next FieldName
End Sub

Public Sub CopyRecordToDictionary(ByVal Record As Scripting.Dictionary, ByVal RecordId As String)
    Dim RecordIndex As Long: RecordIndex = RecordIndexFromId(RecordId)
    Dim FieldName As Variant
    Dim FieldIndex As Long
    For Each FieldName In this.FieldNames
        FieldIndex = FieldIndexFromName(FieldName)
        Record(CStr(FieldName)) = this.Values(RecordIndex, FieldIndex)
    Next FieldName
End Sub

DataTableADODB (backend)

'@Folder "ContactEditor.Storage.Table.Backend"
'@ModuleDescription "Abstracts ADODB backend."
'@PredeclaredId
'@Exposed
'@IgnoreModule FunctionReturnValueDiscarded, IndexedDefaultMemberAccess
Option Explicit

Private Const SQLITE_CONNSTR_PREFIX As String = "sqlite:"

Implements IDataTableStorage

Private Type TDataTable
    Model As DataTableModel
    SQL As SQLlib
    ADO As ADOlib
    AdoCommand As ADODB.Command
    ConnectionString As String
    TableName As String
    FieldNames() As String
    FieldTypes() As ADODB.DataTypeEnum
    FieldMap As Scripting.Dictionary
    IDs As Variant
    TypeCast As FieldFormat
End Type
Private this As TDataTable


Private Sub Class_Initialize()
    Set this.FieldMap = New Scripting.Dictionary
    this.FieldMap.CompareMode = TextCompare
End Sub


Private Sub Class_Terminate()
    Set this.Model = Nothing
    Set this.SQL = Nothing
    Set this.ADO = Nothing
    Set this.FieldMap = Nothing
    On Error Resume Next
    this.AdoCommand.ActiveConnection.Close
    On Error GoTo 0
End Sub


'@Ignore ProcedureNotUsed
Public Property Get SelfIDataTableStorage() As IDataTableStorage
    Set SelfIDataTableStorage = Me
End Property


'@Ignore ProcedureNotUsed
'@Description("Returns class reference.")
Public Property Get Class() As DataTableADODB
    Set Class = DataTableADODB
End Property


'@Ignore ProcedureNotUsed
Public Property Get AdoCommand() As ADODB.Command
    If this.AdoCommand Is Nothing Then
        Set AdoCommand = AdoCommandInit(this.SQL.SelectAll)
    Else
        Set AdoCommand = this.AdoCommand
    End If
End Property


Public Property Get FieldNames() As Variant
    FieldNames = this.FieldNames
End Property
    
    
Public Property Get FieldTypes() As Variant
    FieldTypes = this.FieldTypes
End Property
    
    
Public Property Get FieldMap() As Scripting.Dictionary
    Set FieldMap = this.FieldMap
End Property


'@Ignore ProcedureNotUsed
Public Sub SetTypeCast(Optional ByVal TypeCast As FieldFormat = FieldFormat.CastAsIs)
    this.TypeCast = TypeCast
End Sub


'@Ignore ProcedureNotUsed
'@Description "Returns a new IDataTableStorage object."
Public Function Create(ByVal Model As DataTableModel, ByVal ConnectionString As String, ByVal TableName As String) As IDataTableStorage
    Dim Result As DataTableADODB
    Set Result = New DataTableADODB
    Result.Init Model, ConnectionString, TableName
    Set Create = Result
End Function


'''' Creates a DataTableADODB instance with default interface, on which .Self can be use to access IDataTableStorage
'@Description "Returns a new DataTableADODB object."
Public Function CreateDefault(ByVal Model As DataTableModel, ByVal ConnectionString As String, ByVal TableName As String) As DataTableADODB
    Dim Result As DataTableADODB
    Set Result = New DataTableADODB
    Result.Init Model, ConnectionString, TableName
    Set CreateDefault = Result
End Function


Public Sub Init(ByVal Model As DataTableModel, ByVal ConnectionString As String, ByVal TableName As String)
    Guard.NullReference Model
    Guard.EmptyString ConnectionString
    
    Set this.Model = Model
    Set this.SQL = SQLlib.Create(TableName)
    Set this.ADO = ADOlib.Create
    If LCase$(Left$(ConnectionString, 7)) = SQLITE_CONNSTR_PREFIX Then
        this.ConnectionString = this.ADO.GetSQLiteConnectionString(ConnectionString)("ADO")
    Else
        this.ConnectionString = ConnectionString
    End If
    this.ADO.SetConnectionString this.ConnectionString
    this.TableName = TableName
    
    this.ADO.GetTableMeta this.TableName, this.FieldNames, this.FieldTypes, this.FieldMap
End Sub


Public Function AdoCommandInit(ByVal SQLQuery As String, _
                               Optional ByVal CursorLocation As ADODB.CursorLocationEnum = adUseClient) As ADODB.Command
    If Not this.AdoCommand Is Nothing Then
        On Error Resume Next
        this.AdoCommand.ActiveConnection.Close
        On Error GoTo 0
    End If
            
    Dim CommandText As String
    CommandText = IIf(Len(SQLQuery) > 0, SQLQuery, this.SQL.SelectAll)
    
    Set this.AdoCommand = New ADODB.Command
    With this.AdoCommand
        .CommandType = ADODB.CommandTypeEnum.adCmdText
        .CommandText = CommandText
        .Prepared = True
        .ActiveConnection = this.ConnectionString
        .ActiveConnection.CursorLocation = CursorLocation
    End With
    Set AdoCommandInit = this.AdoCommand
End Function


Public Function AdoRecordset(Optional ByVal SQLQuery As String = vbNullString) As ADODB.Recordset
    Dim Rst As ADODB.Recordset
    Set Rst = New ADODB.Recordset
    With Rst
        Set .Source = IIf(SQLQuery = vbNullString, this.AdoCommand, AdoCommandInit(SQLQuery))
        .CursorLocation = this.AdoCommand.ActiveConnection.CursorLocation
        .CursorType = adOpenStatic
        .LockType = adLockBatchOptimistic
        .CacheSize = 10
        .Open Options:=adAsyncFetch
    
        If .CursorLocation = ADODB.CursorLocationEnum.adUseClient Then
            Set .ActiveConnection = Nothing
        End If
    End With
    Set AdoRecordset = Rst
End Function


Public Function Records(Optional ByVal SQLQuery As String = vbNullString) As Variant
    Dim Rst As ADODB.Recordset
    Set Rst = AdoRecordset(SQLQuery)
    Records = ArrayLib.TransposeArray(Rst.GetRows, OutputArrBase:=1)
End Function


Public Function RecordsAsText() As Variant
    Dim Rst As ADODB.Recordset
    Set Rst = AdoRecordset(this.SQL.SelectAllAsText(this.FieldNames, this.FieldTypes))
    RecordsAsText = ArrayLib.TransposeArray(Rst.GetRows, OutputArrBase:=1)
End Function


Private Sub IDataTableStorage_LoadDataIntoModel()
    With this.Model
        .FieldIndices.RemoveAll
        
        .Values = RecordsAsText
        .FieldNames = this.FieldNames
        Dim FieldName As Variant
        For Each FieldName In this.FieldMap.Keys
            .FieldIndices(FieldName) = this.FieldMap(FieldName)
        Next FieldName
        
        Dim IDs As Variant
        IDs = ArrayLib.GetColumn(.Values, ColumnNumber:=1, OutputArrBase:=1)
        this.IDs = IDs
        
        Dim RecordCount As Long
        RecordCount = UBound(IDs)
        Dim RecordIndex As Long
        For RecordIndex = 1 To RecordCount
            .IdIndices(IDs(RecordIndex)) = RecordIndex
        Next RecordIndex
    End With
End Sub


Private Function IDataTableStorage_GetIds() As Variant
    IDataTableStorage_GetIds = this.IDs
End Function


Private Function IDataTableStorage_GetColumnValues(ByVal FieldName As String) As Variant
    IDataTableStorage_GetColumnValues = ArrayLib.GetColumn( _
        this.Model.Values, _
        ColumnNumber:=this.FieldMap(FieldName), _
        OutputArrBase:=1 _
    )
End Function


Private Sub IDataTableStorage_SaveDataFromModel()
    If Not this.Model.IsDirty Then Exit Sub
    
    Dim AdoCmd As ADODB.Command
    Set AdoCmd = AdoCommandInit(this.SQL.UpdateSingleRecord(this.FieldNames))
    this.ADO.MakeAdoParamsForRecordUpdate this.FieldNames, this.FieldTypes, AdoCmd

    Dim RecordsAffected As Long: RecordsAffected = 0
    Dim Record As Scripting.Dictionary
    Set Record = New Scripting.Dictionary
    Record.CompareMode = TextCompare
    With this.Model
        AdoCmd.ActiveConnection.BeginTrans
        Dim RecordId As Variant
        For Each RecordId In .DirtyRecords.Keys
            .CopyRecordToDictionary Record, RecordId
            this.ADO.RecordToAdoParams Record, AdoCmd
            AdoCmd.Execute RecordsAffected, , adExecuteNoRecords
        Next RecordId
        AdoCmd.ActiveConnection.CommitTrans
        .IsNotDirty
    End With
End Sub

IDataTableStorage (backend interface)

'@Folder "ContactEditor.Storage.Table.Backend"
'@ModuleDescription "Abstracts storage interfaces for DataTableModel. Implemented by storage backends."
'@Interface
'@Exposed
Option Explicit


Public Sub LoadDataIntoModel()
End Sub

Public Sub SaveDataFromModel()
End Sub

Public Function GetIds() As Variant
End Function

Public Function GetColumnValues(ByVal FieldName As String) As Variant
End Function

DataTableManager (manager)

'@Folder "ContactEditor.Storage.Table.Manager"
'@PredeclaredId
'@Exposed
Option Explicit

Implements IDataTableManager

Private Type TDataTableManager
    Model As DataTableModel
    Storage As IDataTableStorage
End Type
Private this As TDataTableManager


Public Function Create(ByVal ClassName As String, ByVal ConnectionString As String, ByVal TableName As String) As IDataTableManager
    Dim Result As DataTableManager
    Set Result = New DataTableManager
    Result.Init ClassName, ConnectionString, TableName
    Set Create = Result
End Function

Public Sub Init(ByVal ClassName As String, ByVal ConnectionString As String, ByVal TableName As String)
    Set this.Model = New DataTableModel
    Set this.Storage = DataTableFactory.CreateInstance(ClassName, this.Model, ConnectionString, TableName)
End Sub

Private Sub Class_Terminate()
    Set this.Model = Nothing
    Set this.Storage = Nothing
End Sub

Private Property Get IDataTableManager_Model() As DataTableModel
    Set IDataTableManager_Model = this.Model
End Property

Private Sub IDataTableManager_LoadDataIntoModel()
    this.Storage.LoadDataIntoModel
End Sub

Private Sub IDataTableManager_SaveDataFromModel()
    this.Storage.SaveDataFromModel
End Sub

IDataTableManager (manager interface)

'@Folder "ContactEditor.Storage.Table.Manager"
'@ModuleDescription "A composition of a data model and a storage class responsible for loading/saving the model data."
'@Interface
'@Exposed
Option Explicit


Public Property Get Model() As DataTableModel
End Property

Public Sub LoadDataIntoModel()
End Sub

Public Sub SaveDataFromModel()
End Sub
\$\endgroup\$
7
  • \$\begingroup\$ You're using ADODB to Excel. This begs the question: "Why aren't you using MSAccess to hold the data?" \$\endgroup\$
    – HackSlash
    Aug 18 at 17:41
  • \$\begingroup\$ @HackSlash I use Excel as a prototyping platform and because I have been using it as my personal database for years. But I do not see any point in migrating from Excel to MS Access. \$\endgroup\$
    – PChemGuy
    Aug 18 at 18:33
  • \$\begingroup\$ Oh, well the biggest reason would be that Excel is not a database. It can't be made to preserve relations and enforce rules on data. I'm sure you'll hit the limitations some day, and it will be too late. When that day comes you'll need a solution yesterday. \$\endgroup\$
    – HackSlash
    Aug 19 at 15:36
  • \$\begingroup\$ I am not using ADODB to access an Excel database. I have an Excel backend in my demo just as an exercise. The whole point is to migrate to an RDBMS; I just have no intentions of dealing with MSAccess. \$\endgroup\$
    – PChemGuy
    Aug 19 at 18:58
  • 1
    \$\begingroup\$ @HackSlash OP's intention is use Excel (as the well known user friendly frontend that it is), to interact with any datastore compatible with ADO technology. Sure this could be done in Access or WPF, but that's not the point. Using Excel-VBA for something like this is a great learning exercise, as it forces the developer to build everything from the ground up. At the end of the day the developer will have designed something functional, and gained some knowledge along the way. Learning in this way is the premise of codereview.stackexchange.com... \$\endgroup\$ Aug 20 at 12:31

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.