Объектно-реляционный маппер для VBA / МС-доступ к


Это моя попытка создать простой объектно-реляционные отображения (ORM) в VBA для DAO и adodb, хранящихся записей, чтобы уменьшить шаблонного кода при преобразовании данных между наборами записей и объектов.

Насколько я смог определить, что это не возможно, чтобы программно получить имя или свойства в VBA пользовательский класс другие, чем чтение кода в программу напрямую, что бы не в производственной среде, используя составленный accde по базам данных или защитой проектов. Некоторые первоначальные ручной работы для сопоставления свойств класса кажется неизбежным. В IMappable интерфейс определяет требуемые свойства и методы класса должны реализовать для того, чтобы быть потребляемой картографа (IMapper).

IMappable

'@Description("Provides an interface to allow a class to be mapped by an object-relational mapper.")
'@Folder("VBALibrary.Data.ObjectRelationalMapping")
'@Interface

Option Explicit

Public Property Get MappedProperties() As Dictionary
End Property

Public Property Get TableName() As String
End Property

Public Function CreateNew() As IMappable
End Function

Public Function GetPropertyValue(ByVal strPropertyName As String) As Variant
End Function

Public Sub LetPropertyValue(ByVal strPropertyName As String, ByVal vntValue As Variant)
End Sub

Конкретный экземпляр этого класса может выглядеть следующим образом:

'@Folder("VBALibrary.Tests.Data.ObjectRelationalMapping")
Option Explicit

Implements IMappable

Private Type TClass
    PersonId As Long
    FavoriteColor As String
    PersonName As String
    PersonBirthdate As Date
End Type

Private this As TClass

Private mobjClassProperties As Dictionary


' =============================================================================
' PROPERTIES
' =============================================================================

Public Property Get PersonId() As Long
    PersonId = this.PersonId
End Property
Public Property Let PersonId(ByVal Value As Long)
    this.PersonId = Value
End Property

Public Property Get FavoriteColor() As String
    FavoriteColor = this.FavoriteColor
End Property
Public Property Let FavoriteColor(ByVal Value As String)
    this.FavoriteColor = Value
End Property

Public Property Get PersonName() As String
    PersonName = this.PersonName
End Property
Public Property Let PersonName(ByVal Value As String)
    this.PersonName = Value
End Property

Public Property Get PersonBirthdate() As Date
    PersonBirthdate = this.PersonBirthdate
End Property
Public Property Let PersonBirthdate(ByVal Value As Date)
    this.PersonBirthdate = Value
End Property


' =============================================================================
' INTERFACE IMPLEMENTATIONS
' =============================================================================

Private Property Get IMappable_MappedProperties() As Dictionary
    If mobjClassProperties Is Nothing Then
        Set mobjClassProperties = New Dictionary
        With mobjClassProperties
            .Add "PersonId", "Id"
            .Add "FavoriteColor", "FavoriteColor"
            .Add "PersonName", "Name"
            .Add "PersonBirthdate", "Birth Date"
        End With
    End If
    Set IMappable_MappedProperties = mobjClassProperties
End Property

Private Property Get IMappable_TableName() As String
    IMappable_TableName = "MockMappable"
    ' IMappable_TableName = "MockMappableWithAutonumber"
End Property

Private Function IMappable_CreateNew() As IMappable
    Set IMappable_CreateNew = New MockMappable
End Function

Private Function IMappable_GetPropertyValue(ByVal strPropertyName As String) As Variant
    IMappable_GetPropertyValue = CallByName(Me, strPropertyName, VbGet)
End Function

Private Sub IMappable_LetPropertyValue(ByVal strPropertyName As String, ByVal vntValue As Variant)
    CallByName Me, strPropertyName, VbCallType.VbLet, vntValue
End Sub

В MappedProperties словарь просто хранит имя класса таблицы имя поля, с которым его связывают, допуская различия в именования между двумя. Имятаблицы хранит имя связанной таблицы базы данных, снова допуская различия между таблицей и имя класса.

Функция CreateNew фабрика в класс, который возвращает новый экземпляр своего собственного конкретного класса. Как IMapper класс знает только о IMappable интерфейс и ничего о конкретной реализации передается на него, мне нужен был способ, чтобы иметь возможность создавать новые предметы из той же comcrete класс, когда, например, сопоставление нескольких записей базы данных к коллекции объектов. Если есть способ, чтобы инстанцировать классы VBA с именем таким же образом, как ActiveX объекты создаются функцией createobject("Имя_класса"), затем что бы снять нужно для метода фабрики.

В GetPropertyValue и функции LetPropertyValue просто оберните функцию CallByName, который читает и пишет свойств класса. Опять же, как маппера класса знают о IMappable интерфейс, а не конкретной реализации, CallByName называется от маппера класс, выбрасывает ошибки во время выполнения, потому что свойства стараясь быть изменены отсутствуют в IMappable интерфейс.

Интерфейс для класса IMapper должен выглядеть достаточно знакомы любому, кто использовал ОРМ.

IMapper

'@Description("Provides an interface to implement an object-relational mapper.")
'@Folder("VBALibrary.Data.ObjectRelationalMapping")
'@Interface

Option Explicit

Public Function DeleteAll(ByVal obj As IMappable) As Long
End Function

Public Function DeleteMultiple(ByVal col As Collection) As Long
End Function

Public Sub DeleteSingle(ByVal obj As IMappable)
End Sub

Public Function GetAll(ByVal obj As IMappable) As Collection
End Function

Public Function GetMultiple(ByVal obj As IMappable, ByVal strQuery As String) As Collection
End Function

Public Function GetMultipleByFilter(ByVal obj As IMappable, ByVal strFilterCriteria As String) As Collection
End Function

Public Function GetSingle(ByRef obj As IMappable, ByVal vntPrimaryKey As Variant) As Boolean
End Function

Public Sub InsertMultiple(ByRef col As Collection)
End Sub

Public Sub InsertSingle(ByRef obj As IMappable)
End Sub

Public Function ItemExists(ByVal obj As IMappable) As Boolean
End Function

Public Sub UpdateMultiple(ByVal col As Collection)
End Sub

Public Sub UpdateSingle(ByVal obj As IMappable)
End Sub

Public Sub UpsertMultiple(ByVal col As Collection)
End Sub

Public Sub UpsertSingle(ByVal obj As IMappable)
End Sub

Реализация тоже довольно стандартны.

'@Description("An object-relational mapper to map between DAO tables and VBA class objects.")
'@Folder("VBALibrary.Data.ObjectRelationalMapping")

Option Explicit

Implements IMapper

Private Const mlngErrorNumber As Long = vbObjectError + 513
Private Const mstrClassName As String = "OrmDao"

Private Enum WriteOption
    Insert
    Update
End Enum


' =============================================================================
' PUBLIC METHODS
' =============================================================================

'@Description("Deletes all objects of the provided IMappable type from the data store.")
'@Param("obj: An IMappable of the type to be deleted.")
'@Returns("The number of records deleted from the data store.")
Public Function DeleteAll(ByVal obj As IMappable) As Long
    DeleteAll = IMapper_DeleteAll(obj)
End Function

' =============================================================================

'@Description("Deletes a collection of IMappable objects from the data store.")
'@Param("col: A collection of IMappable objects to be deleted."
'@Returns("The number of records deleted.")
Public Function DeleteMultiple(ByVal col As Collection) As Long
    DeleteMultiple = IMapper_DeleteMultiple(col)
End Function

' =============================================================================

'@Description("Deletes a single IMappable object from the data store.")
'@Param("obj: An IMappable object to be deleted.")
Public Sub DeleteSingle(ByVal obj As IMappable)
    IMapper_DeleteSingle obj
End Sub

' =============================================================================

'@Description("Maps records from the data store to a collection of IMappable objects.")
'@Param("obj: A concrete IMappable instance of the type to which the records will be mapped.")
'@Returns("A collection of mapped objects.")
Public Function GetAll(ByVal obj As IMappable) As Collection
    Set GetAll = IMapper_GetAll(obj)
End Function

' =============================================================================

'@Description("Maps a recordset retrieved by the provided query to a collection of IMappable objects.")
'@Param("obj: A concrete IMappable instance of the type to which the records will be mapped.")
'@Param("strQuery: A SQL query defining the result set.")
'@Returns("A collection of mapped objects.")
Public Function GetMultiple(ByVal obj As IMappable, ByVal strQuery As String) As Collection
    Set GetMultiple = IMapper_GetMultiple(obj, strQuery)
End Function

' =============================================================================

'@Description("Maps a recordset retrieved by the provided filter criteria to a collection of IMappable objects.")
'@Param("obj: A concrete IMappable instance of the type to which the records will be mapped.")
'@Returns("A collection of mapped objects.")
Public Function GetMultipleByFilter(ByVal obj As IMappable, ByVal strFilterCriteria As String) As Collection
    Set GetMultipleByFilter = IMapper_GetMultipleByFilter(obj, strFilterCriteria)
End Function

' =============================================================================

'@Description("Maps the values of a single record to an IMappable object passed by reference.")
'@Param("obj: A concrete IMappable instance of the type to which the records will be mapped.")
'@Param("vntPrimaryKey: The record's primary key.")
'@Returns("A value indicating whether the retrieval was successful.")
'@Remarks("This procedure changes the values of the object passed by reference.")
Public Function GetSingle(ByRef obj As IMappable, ByVal vntPrimaryKey As Variant) As Boolean
    GetSingle = IMapper_GetSingle(obj, vntPrimaryKey)
End Function

' =============================================================================

'@Description("Inserts a collection of IMappable objects into the data store.")
'@Param("col: A collection of IMappable objects to be inserted into the data store.")
'@Remarks("Primary keys autogenerated by the insert operation are assigned to the object by reference.")
Public Sub InsertMultiple(ByRef col As Collection)
    IMapper_InsertMultiple col
End Sub

' =============================================================================

'@Description("Inserts an IMappable instance into the data store.")
'@Param("obj: An IMappable object to be inserted into the data store.")
'@Remarks("Primary keys autogenerated by the insert operation are assigned to the object by reference.")
Public Sub InsertSingle(ByRef obj As IMappable)
    IMapper_InsertSingle obj
End Sub

' =============================================================================

'@Description("Determines if the provided item exists in the data store.")
'@Param("The IMappable object to be tested.")
'@Returns("A value indicating whether the provided item exists in the data store.")
Public Function ItemExists(ByVal obj As IMappable) As Boolean
    ItemExists = IMapper_ItemExists(obj)
End Function

' =============================================================================

'@Description("Updates the data store record associated with each IMappable object in the provided collection.")
'@Param("col: A collection of IMappable objects to be updated.")
Public Sub UpdateMultiple(ByVal col As Collection)
    IMapper_UpdateMultiple col
End Sub

' =============================================================================

'@Description("Updates the data store record associated with the provided IMappable object.")
'@Param("obj: An IMappable object to be updated.")
Public Sub UpdateSingle(ByVal obj As IMappable)
    IMapper_UpdateSingle obj
End Sub

' =============================================================================

'@Description("Upserts a collection of IMappable objects into the data store.")
'@Param("col: A collection of IMappable objects to be upserted.")
Public Sub UpsertMultiple(ByVal col As Collection)
    IMapper_UpsertMultiple col
End Sub

' =============================================================================

'@Description("Upserts an IMappable object into the data store.")
'@Param("obj: An IMappable object to be upserted.")
Public Sub UpsertSingle(ByVal obj As IMappable)
    IMapper_UpsertSingle obj
End Sub


' =============================================================================
' PRIVATE METHODS
' =============================================================================

'@Description("Determines whether the provided field in the provided table autoincrements.")
'@Param("The table name in which the field resides.")
'@Param("The field to be tested.")
'@Returns("A value indicating whether the provided field autoincrements.")
Private Function FieldAutoIncrements(ByVal strTableName As String, ByVal strFieldName As String) As Boolean

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset
Dim fld As DAO.Field

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(strTableName, RecordsetOptionEnum.dbReadOnly)
    Set fld = rec.Fields(strFieldName)

    FieldAutoIncrements = (fld.Attributes And FieldAttributeEnum.dbAutoIncrField) = FieldAttributeEnum.dbAutoIncrField

End Function

' =============================================================================

'@Description("Retrieves the dictionary key that corresponds to the provided item.")
'@Param("objDictionary: The dictionary containing the key-value pair.")
'@Param("vntItem: A dictionary item..")
'@Returns("A dictionary key value.")
Private Function GetKeyFromItem(ByVal objDictionary As Object, ByVal vntItem As Variant) As Variant
Dim vntKey As Variant
    For Each vntKey In objDictionary.Keys
        If objDictionary.Item(vntKey) = vntItem Then
            GetKeyFromItem = vntKey
            Exit Function
        End If
    Next vntKey
End Function

' =============================================================================

'@Description("Determines the primary key field set on the table.")
'@Param("strTableName: The name of the table from which to retrieve the primary key field.")
'@Returns("The name of the primary key field.")
Private Function GetPrimaryKeyFieldName(ByVal strTableName As String) As String

Dim dbCurrent As DAO.Database
Dim tdf As DAO.TableDef
Dim intIndexNumber As Integer
Dim idx As DAO.Index

    Set dbCurrent = CurrentDb
    Set tdf = dbCurrent.TableDefs(strTableName)

    For intIndexNumber = 0 To tdf.Indexes.Count - 1
        Set idx = tdf.Indexes(intIndexNumber)
        If idx.Primary = True Then
            GetPrimaryKeyFieldName = idx.Fields(0).Name
        End If
    Next intIndexNumber

End Function

' =============================================================================

'@Description("Maps an IMappable object to a new record in the provided recordset.")
'@Param("rec: The recordset where the object will be mapped.")
'@Param("obj: An instance of the IMappable type to be mapped.")
'@Param("intWriteOption: An enumerated value indicating the write option (insert or update) for the operation."
'@Param("strPrimaryKeyFieldName: The name of the recordset's primary key field.")
'@Param("blnPrimaryKeyAutoIncrements: A value indicating whether the primary key field autoincrements.")
'@Remarks("This procedure changes the values of the object passed by reference.")
Private Sub MapObjectToRecord(ByRef rec As DAO.Recordset, ByRef obj As IMappable, ByVal intWriteOption As WriteOption, ByVal strPrimaryKeyFieldName As String, ByVal blnPrimaryKeyAutoIncrements As Boolean)

Dim strPrimaryKeyClassProperty As String
Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String

    If intWriteOption = WriteOption.Insert Then
        rec.AddNew
    ElseIf intWriteOption = WriteOption.Update Then
        rec.Edit
    End If

    For Each vntProperty In obj.MappedProperties

        strClassProperty = CStr(vntProperty)
        strTableProperty = obj.MappedProperties.Item(vntProperty)

        If strTableProperty = strPrimaryKeyFieldName Then
            strPrimaryKeyClassProperty = strClassProperty

            If Not blnPrimaryKeyAutoIncrements Then
                rec.Fields(strTableProperty).Value = obj.GetPropertyValue(strClassProperty)
            End If
        Else
            rec.Fields(strTableProperty).Value = obj.GetPropertyValue(strClassProperty)
        End If

    Next vntProperty
    obj.LetPropertyValue strPrimaryKeyClassProperty, rec.Fields(strPrimaryKeyFieldName)
    rec.Update

End Sub

' =============================================================================

'@Description("Maps the current recordset record to an IMappable objects.")
'@Param("rec: The recordset containing the current record to be mapped.")
'@Param("obj: An instance of the IMappable type to be mapped.")
'@Remarks("This procedure changes the values of the object passed by reference.")
Private Sub MapRecordToObject(ByRef rec As DAO.Recordset, ByRef obj As IMappable)

Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String

    For Each vntProperty In obj.MappedProperties

        strClassProperty = CStr(vntProperty)
        strTableProperty = obj.MappedProperties.Item(vntProperty)

        If Not IsNull(rec.Fields(strTableProperty).Value) Then
            obj.LetPropertyValue strClassProperty, rec.Fields(strTableProperty).Value
        End If

    Next vntProperty

End Sub

' =============================================================================

'@Description("Maps the provided recordset to a collection of IMappable objects.")
'@Param("rec: The recordset to be mapped.")
'@Param("obj: A concrete instance of the IMappable type to be mapped.")
'@Returns("A collection of IMappable objects.")
Private Function MapRecordsetToCollection(ByVal rec As DAO.Recordset, ByVal obj As IMappable) As Collection

Dim objToAdd As IMappable
Dim col As Collection

    Set col = New Collection
    Do While Not rec.BOF And Not rec.EOF
        Set objToAdd = obj.CreateNew
        MapRecordToObject rec, objToAdd
        col.Add objToAdd
        rec.MoveNext
    Loop

    Set MapRecordsetToCollection = col

End Function

' =============================================================================

'@Description("Converts a value to an SQL-friendly string.")
'@Param("The value to be parsed.")
'@Returns("An SQL-friendly string representation of the value.")
Private Function ParseSqlCriteria(ByVal vntCriteria As Variant) As String

    If IsDate(vntCriteria) Then
        ParseSqlCriteria = "#" & CDate(vntCriteria) & "#"

    ElseIf IsNumeric(vntCriteria) Then
        ParseSqlCriteria = CStr(vntCriteria)

    Else
        ParseSqlCriteria = "'" & CStr(vntCriteria) & "'"

    End If

End Function

' =============================================================================

'@Description("Wraps field and table names containing spaces with brackets.")
'@Param("The field or table name to wrap.")
'@Returns("A query-safe field or table name.")
Private Function WrapUnsafeNames(ByVal strName As String) As String
    If InStr(1, strName, " ", vbTextCompare) > 0 Then
        WrapUnsafeNames = "[" & strName & "]"
    Else
        WrapUnsafeNames = strName
    End If
End Function


' =============================================================================
' INTERFACE IMPLEMENTATION
' =============================================================================

Private Function IMapper_DeleteAll(ByVal obj As IMappable) As Long

Dim strQuery As String
Dim dbCurrent As DAO.Database

    strQuery = "DELETE * FROM " & WrapUnsafeNames(obj.TableName) & ";"
    Set dbCurrent = CurrentDb
    dbCurrent.Execute strQuery, RecordsetOptionEnum.dbFailOnError
    IMapper_DeleteAll = dbCurrent.RecordsAffected

End Function

' =============================================================================

Private Function IMapper_DeleteMultiple(ByVal col As Collection) As Long

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim vntProperty As Variant
Dim strProperty As String

Dim vntItem As Variant
Dim objItem As IMappable
Dim strPrimaryKeys As String
Dim strQuery As String

Dim dbCurrent As DAO.Database

    If col.Count = 0 Then
        Exit Function
    End If

    Set objItem = col.Item(1)
    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(objItem.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(objItem.MappedProperties, strPrimaryKeyFieldName))

    For Each vntItem In col
        Set objItem = vntItem
        strPrimaryKeys = strPrimaryKeys & ParseSqlCriteria(CStr(objItem.GetPropertyValue(strPrimaryKeyRecordName))) & ","
    Next vntItem

    strQuery = "DELETE * FROM " & WrapUnsafeNames(objItem.TableName) & " WHERE " & WrapUnsafeNames(strPrimaryKeyFieldName) & " IN (" & strPrimaryKeys & ");"

    Set dbCurrent = CurrentDb
    dbCurrent.Execute strQuery, RecordsetOptionEnum.dbFailOnError
    IMapper_DeleteMultiple = dbCurrent.RecordsAffected

End Function

' =============================================================================

Private Sub IMapper_DeleteSingle(ByVal obj As IMappable)

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim strPrimaryKey As String

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset
Dim recFiltered As DAO.Recordset

Const strProcedureName As String = "DeleteSingle"

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(obj.MappedProperties, strPrimaryKeyFieldName))
    strPrimaryKey = ParseSqlCriteria(CStr(obj.GetPropertyValue(strPrimaryKeyRecordName)))

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenDynaset)
    rec.Filter = strPrimaryKeyFieldName & " = " & strPrimaryKey

    Set recFiltered = rec.OpenRecordset
    With recFiltered

        If .RecordCount > 1 Then
            Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "More than one result found."
        End If

        .Delete

    End With

End Sub

' =============================================================================

Private Function IMapper_GetAll(ByVal obj As IMappable) As Collection

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenSnapshot, RecordsetOptionEnum.dbReadOnly)
    Set IMapper_GetAll = MapRecordsetToCollection(rec, obj)

End Function

' =============================================================================

Private Function IMapper_GetMultiple(ByVal obj As IMappable, ByVal strQuery As String) As Collection

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(strQuery, RecordsetTypeEnum.dbOpenSnapshot, RecordsetOptionEnum.dbReadOnly)
    Set IMapper_GetMultiple = MapRecordsetToCollection(rec, obj)

End Function

' =============================================================================

Public Function IMapper_GetMultipleByFilter(ByVal obj As IMappable, ByVal strFilterCriteria As String) As Collection

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset
Dim recFiltered As DAO.Recordset

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenSnapshot, RecordsetOptionEnum.dbReadOnly)
    rec.Filter = strFilterCriteria
    Set recFiltered = rec.OpenRecordset
    Set IMapper_GetMultipleByFilter = MapRecordsetToCollection(recFiltered, obj)

End Function

' =============================================================================

Private Function IMapper_GetSingle(ByRef obj As IMappable, ByVal vntPrimaryKey As Variant) As Boolean

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKey As String
Dim strQuery As String

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String

Const strProcedureName As String = "GetSingleByPrimaryKey"

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    strPrimaryKey = ParseSqlCriteria(vntPrimaryKey)
    strQuery = "SELECT * FROM " & WrapUnsafeNames(obj.TableName) & " WHERE " & WrapUnsafeNames(strPrimaryKeyFieldName) & " = " & strPrimaryKey & ";"

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenSnapshot, RecordsetOptionEnum.dbReadOnly)
    With rec

        If .RecordCount = 0 Then
            IMapper_GetSingle = False
            Exit Function
        End If

        If .RecordCount > 1 Then
            IMapper_GetSingle = False
            Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "More than one result found."
        End If

        MapRecordToObject rec, obj

    End With

    IMapper_GetSingle = True

End Function

' =============================================================================

Private Sub IMapper_InsertSingle(ByRef obj As IMappable)

Dim strPrimaryKeyFieldName As String
Dim blnPrimaryKeyAutoIncrements As Boolean
Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(obj.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName)
    MapObjectToRecord rec, obj, WriteOption.Insert, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements

End Sub

' =============================================================================

Private Sub IMapper_InsertMultiple(ByRef col As Collection)

Dim strPrimaryKeyClassProperty As String
Dim strPrimaryKeyFieldName As String
Dim blnPrimaryKeyAutoIncrements As Boolean

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

Dim vntItem As Variant
Dim objItem As IMappable
Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String

    If col.Count = 0 Then
        Exit Sub
    End If

    Set objItem = col.Item(1)
    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(objItem.TableName)
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(objItem.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(objItem.TableName)

    For Each vntItem In col
        Set objItem = vntItem
        MapObjectToRecord rec, objItem, WriteOption.Insert, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements
    Next vntItem

End Sub

' =============================================================================

Private Function IMapper_ItemExists(ByVal obj As IMappable) As Boolean

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim strPrimaryKey As String
Dim strQuery As String

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(obj.MappedProperties, strPrimaryKeyFieldName))
    strPrimaryKey = ParseSqlCriteria(CStr(obj.GetPropertyValue(strPrimaryKeyRecordName)))
    strQuery = "SELECT " & WrapUnsafeNames(strPrimaryKeyFieldName) & " FROM " & WrapUnsafeNames(obj.TableName) & " WHERE " & WrapUnsafeNames(strPrimaryKeyFieldName) & " = " & strPrimaryKey & ";"

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(strQuery, RecordsetTypeEnum.dbOpenSnapshot)
    IMapper_ItemExists = rec.RecordCount > 0

End Function

' =============================================================================

Private Sub IMapper_UpdateMultiple(ByVal col As Collection)

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim blnPrimaryKeyAutoIncrements As Boolean
Dim strQuery As String

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

Dim vntItem As Variant
Dim objItem As IMappable

Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String
Dim strPrimaryKeyValue As String

Const strProcedureName As String = "UpdateMultiple"

    If col.Count = 0 Then
        Exit Sub
    End If

    Set objItem = col.Item(1)
    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(objItem.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(objItem.MappedProperties, strPrimaryKeyFieldName))
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(objItem.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(objItem.TableName, RecordsetTypeEnum.dbOpenDynaset)
    With rec

        For Each vntItem In col
            Set objItem = vntItem

            .FindFirst strPrimaryKeyFieldName & "=" & ParseSqlCriteria(objItem.GetPropertyValue(strPrimaryKeyRecordName))

            If .NoMatch Then
                Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Item not found in the data store."
            End If

            MapObjectToRecord rec, objItem, WriteOption.Update, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements

        Next vntItem

    End With

End Sub

' =============================================================================

Private Sub IMapper_UpdateSingle(ByVal obj As IMappable)

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim blnPrimaryKeyAutoIncrements As Boolean

Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset
Dim recFiltered As DAO.Recordset

Dim vntProperty As Variant
Dim strClassProperty As String
Dim strTableProperty As String

Const strProcedureName As String = "UpdateSingle"

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(obj.MappedProperties, strPrimaryKeyFieldName))
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(obj.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenDynaset)
    rec.Filter = strPrimaryKeyFieldName & " = " & obj.GetPropertyValue(strPrimaryKeyRecordName)

    Set recFiltered = rec.OpenRecordset
    With recFiltered

        If .RecordCount = 0 Then
            Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Item not found in the data store."
        End If

        If .RecordCount > 1 Then
            Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "More than one possible record match found in the data store."
        End If

        MapObjectToRecord rec, obj, WriteOption.Update, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements

    End With

End Sub

' =============================================================================

Public Sub IMapper_UpsertMultiple(ByVal col As Collection)

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim blnPrimaryKeyAutoIncrements As Boolean
Dim blnItemExists As Boolean
Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset
Dim vntItem As Variant
Dim objItem As IMappable

    If col.Count = 0 Then
        Exit Sub
    End If

    Set objItem = col.Item(1)
    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(objItem.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(objItem.MappedProperties, strPrimaryKeyFieldName))
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(objItem.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(objItem.TableName, RecordsetTypeEnum.dbOpenDynaset)

    For Each vntItem In col
        Set objItem = vntItem

            rec.FindFirst strPrimaryKeyFieldName & "=" & ParseSqlCriteria(objItem.GetPropertyValue(strPrimaryKeyRecordName))

            If rec.NoMatch Then
                MapObjectToRecord rec, objItem, WriteOption.Insert, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements
            Else
                MapObjectToRecord rec, objItem, WriteOption.Update, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements
            End If

    Next vntItem

End Sub

' =============================================================================

Public Sub IMapper_UpsertSingle(ByVal obj As IMappable)

Dim strPrimaryKeyFieldName As String
Dim strPrimaryKeyRecordName As String
Dim blnPrimaryKeyAutoIncrements As Boolean
Dim dbCurrent As DAO.Database
Dim rec As DAO.Recordset

    strPrimaryKeyFieldName = GetPrimaryKeyFieldName(obj.TableName)
    strPrimaryKeyRecordName = CStr(GetKeyFromItem(obj.MappedProperties, strPrimaryKeyFieldName))
    blnPrimaryKeyAutoIncrements = FieldAutoIncrements(obj.TableName, strPrimaryKeyFieldName)

    Set dbCurrent = CurrentDb
    Set rec = dbCurrent.OpenRecordset(obj.TableName, RecordsetTypeEnum.dbOpenDynaset)

    rec.FindFirst strPrimaryKeyFieldName & "=" & ParseSqlCriteria(obj.GetPropertyValue(strPrimaryKeyRecordName))

    If rec.NoMatch Then
        MapObjectToRecord rec, obj, WriteOption.Insert, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements
    Else
        MapObjectToRecord rec, obj, WriteOption.Update, strPrimaryKeyFieldName, blnPrimaryKeyAutoIncrements
    End If

End Sub

' =============================================================================

Главное, чтобы отметить, что конкретной реализацией IMappable объект всегда передается на картографа, либо самостоятельно, либо в коллекции, так что маппер либо имеет уже встроенный контейнер нужного типа, в котором для заполнения базы данных информацией, или завод, на котором создают один или несколько объектов для заполнения. Я хотел бы, чтобы устранить необходимость для этого и сможете создавать объекты правильной конкретный тип на лету, если кто имеет какие-либо хорошие решения.

Объект adodb реализации IMapper также доступна здесь. Тесты для обоих интерфейсов доступен здесь.



509
4
задан 10 марта 2018 в 03:03 Источник Поделиться
Комментарии