ContactEditor — приложение Excel VBA db: библиотека хранилища

Связаться с редактором использует Excel VBA в качестве прототипа платформы для менеджера персональной информации, сочетающего шаблон «Модель, представление, докладчик» (MVP) и постоянный менеджер хранилища.

Рис. 1. Приложение «Менеджер данных»

Дизайн части MVP следует идеям / руководствам / коду из RubberDuck VBA. блог а также демонстрации. База данных содержит единую таблицу, заполненную фиктивными контактными данными. Графический интерфейс пользователя имеет одну пользовательскую форму, которая представляет пользователю данные одной записи. Функциональность «MVP⇔DB» реализована в виде библиотеки хранения с подключаемой архитектурой.

Рисунок 2. Диаграмма классов DataTable

Библиотека хранилища содержит два класса моделей данных: DataTableModel а также DataRecordModel. DataTableModel содержит набор строк, полученных из базы данных (в настоящее время поддерживается только «SELECT * FROM TABLE_NAME»), и DataRecordModel кэширует одну запись, загруженную в пользовательскую форму. Каждый тип хранилища (например, лист Excel или база данных ADODB) представлен одним внутренним классом, абстрагирующим хранилище (например, DataRecordWSheet или DataTableADODB) и реализации связанных IDataTableStorage / IDataRecordStorage интерфейс.

С точки зрения вызывающего кода объект API верхнего уровня — это диспетчер данных (DataTableManager / DataRecordManager) инкапсулирует экземпляр модели данных и связанный экземпляр серверной части. Дополнительно менеджеры данных реализуют IDataTableManager / IDataRecordManager интерфейсы и абстрактные фабричные классы IDataTableFactory / IDataRecordFactory также определены, как показано на рис. DataTableModel семья).

Обратите внимание, этот пост охватывает только DataTableModel семья. Взяв во внимание DataRecordModel семья, пожалуйста, посмотрите проектная документация. Кроме того, полный исходный код и тесты доступны на репозиторий проекта.

DataTableModel (модель)

'@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 (серверная часть)

'@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 (внутренний интерфейс)

'@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 (менеджер)

'@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 (интерфейс менеджера)

'@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