5
\$\begingroup\$

This is my attempt to create simple object-relational mappers (ORM) in VBA for DAO and ADODB recordsets to reduce boilerplate code when converting data between recordsets and objects.

As far as I've been able to determine, it's not possible to programmatically retrieve the name or properties of a VBA custom class other than reading the code in the VBE directly, an operation that would fail in a production environment using compiled accde databases or protected projects. Some initial manual work to map class properties seems unavoidable. The IMappable interface defines the required properties and methods a class must implement in order to be consumed by a mapper (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

A concrete instance of this class might look as follows:

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

The MappedProperties dictionary simply stores the class property name with the table field name with which its associated, allowing for differences in naming conventions between the two. TableName stores the name of the associated database table, again allowing for differences between table and class name.

The CreateNew function is a factory within the class that returns a new instance of its own concrete class. As an IMapper class knows only about the IMappable interface and nothing about the concrete implementation being passed to it, I needed a way to be able to create new objects of the same comcrete class when, for instance, mapping multiple database records to a collection of objects. If there were a way to instantiate VBA classes by name in the same way as ActiveX objects are instantiated by CreateObject("ClassName"), then that would remove the need for the factory method.

The GetPropertyValue and LetPropertyValue functions simply wrap the CallByName function, which reads and writes the class's properties. Again, as the mapper class only knows about the IMappable interface and not the concrete implementation, CallByName called from the mapper class throws a runtime error because the properties trying to be changed do not exist in the IMappable interface.

The interface for an IMapper class should look fairly familiar to anyone who has used an ORM.

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

The implementation is also fairly standard.

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

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

The main thing to note is that a concrete implementation of an IMappable object is always passed to the mapper, either by itself or within a collection, so that the mapper either has an already built container of the correct type in which to populate the database information, or a factory in which to create one or more objects to populate. I would love to eliminate the need for this and be able to create objects of the correct concrete type on the fly, if anyone has any good solutions.

An ADODB implementation of IMapper is also available here. Tests for both interfaces available here.

\$\endgroup\$
  • \$\begingroup\$ I believe that the Microsoft Typelib Info Library(tblinf32.dll) used to allow you to get the properties names of custom classes. Unfortunately, I do not believe that it is supports 64 bit systems. \$\endgroup\$ – user109261 Mar 10 '18 at 18:46
  • \$\begingroup\$ @thomas maybe related? \$\endgroup\$ – Raystafarian Mar 11 '18 at 22:22
  • \$\begingroup\$ @Raystafarian That's interesting and definitely the same library. Not to take away from this post, but MZ Tools does an excellent job documenting VBA Projects. \$\endgroup\$ – user109261 Mar 11 '18 at 23:08
  • \$\begingroup\$ I don't understand your test setup. If I use vba-orm-test, I need to have a MockMappable class and an OrmTests module that implements the class. But I'm missing an IMapper and IMappable which are called for. \$\endgroup\$ – Raystafarian Mar 13 '18 at 23:09
  • \$\begingroup\$ I managed to get my hands on a copy of tlbinf32.dll and register it. It worked on my 64-bit system, with 32-bit version of Office. I did not find a way to use it to create a class by specifying its name. It did allow one to iterate a class's properties, but not if the class is a concrete instance that implements an interface. It was a promising lead, but I don't think I can use it. \$\endgroup\$ – FolkCoder Mar 14 '18 at 10:59

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.