DbRecordset: Updatable recordset with transaction and affected rows count check

Question

DbRecordset is a new class added to a fork of the SecureADODB library, which wraps the ADODB.Recordset class. It complements the functionality of the DbParameters class from the previous post and focuses on updatable recordsets. IDbRecordset class formalizes its public interface providing methods for querying and updating databases.

DbRecordset.IDbRecordset_UpdateRecordset wraps ADODB.Recordset.UpdateBatch method in a database transaction and verifies that expected affected rows count matches the number obtained from the database (affected rows count feature has been implemented for SQLite only).

DbRecordset

'@Folder "SecureADODB.DbRecordset"
'@ModuleDescription "A thin wrapper around an ADODB recordset."
'@PredeclaredId
'@Exposed
Option Explicit

Implements IDbRecordset

'@MemberAttribute VB_VarHelpID, -1
Private WithEvents AdoRecordset As ADODB.Recordset
Private Type TRecordset
    cmd As IDbCommand
    OpenOptions As Long
    DataQT As Excel.QueryTable
End Type
Private this As TRecordset


Public Function Create(ByVal cmd As IDbCommand, _
              Optional ByVal Disconnected As Boolean = True, _
              Optional ByVal CacheSize As Long = 10, _
              Optional ByVal CursorType As ADODB.CursorTypeEnum = -1, _
              Optional ByVal LockType As ADODB.LockTypeEnum = adLockReadOnly, _
              Optional ByVal AsyncMode As Boolean = False, _
              Optional ByVal AsyncOption As ADODB.ExecuteOptionEnum = 0) As IDbRecordset
    Dim Instance As DbRecordset
    Set Instance = New DbRecordset
    Instance.Init cmd, Disconnected, CacheSize, CursorType, LockType, AsyncMode, AsyncOption
    Set Create = Instance
End Function


'''' For updatable recordset use LockType = adLockBatchOptimistic
'@Description("Default constructor")
Friend Sub Init(ByVal cmd As IDbCommand, _
            Optional ByVal Disconnected As Boolean = True, _
            Optional ByVal CacheSize As Long = 10, _
            Optional ByVal CursorType As ADODB.CursorTypeEnum = -1, _
            Optional ByVal LockType As ADODB.LockTypeEnum = adLockReadOnly, _
            Optional ByVal AsyncMode As Boolean = False, _
            Optional ByVal AsyncOption As ADODB.ExecuteOptionEnum = 0)
    Set AdoRecordset = New ADODB.Recordset
    
    Set this.cmd = cmd
    
    If Disconnected Then
        AdoRecordset.CursorLocation = adUseClient
        AdoRecordset.CursorType = adOpenStatic
    Else
        AdoRecordset.CursorLocation = adUseServer
        AdoRecordset.CursorType = adOpenForwardOnly
    End If
    
    AdoRecordset.LockType = LockType
    
    AdoRecordset.CacheSize = CacheSize
    If CursorType > 0 Then
        AdoRecordset.CursorType = CursorType
    End If
    this.OpenOptions = AsyncOption Or (adAsyncFetch And AsyncMode)
End Sub


'@Description "Outputs Recordset to Excel Worksheet via QueryTable"
Friend Function RecordsetToQT(ByVal OutputRange As Excel.Range, _
                     Optional ByVal AdoRst As ADODB.Recordset = Nothing) As Excel.QueryTable
    Guard.NullReference OutputRange
    
    Dim rst As ADODB.Recordset
    Set rst = IIf(AdoRst Is Nothing, AdoRecordset, AdoRst)
    rst.MoveFirst
    
    Dim QTs As Excel.QueryTables
    Set QTs = OutputRange.Worksheet.QueryTables
    
    '''' Cleans up target area before binding the data.
    '''' Provided range reference used to indicate the left column and
    '''' Recordset.Fields.Count determines the width.
    '''' If EntireColumn.Delete method is used, Range object becomes invalid, so
    '''' a textual address must be saved to reset the Range reference.
    '''' However, when multiple QTs are bound to the same worksheet,
    '''' EntireColumn.Delete shifts columns to the left, so the target range
    '''' may not be clear. EntireColumn.Clear clears the contents.
    Dim FieldsCount As Long
    FieldsCount = rst.Fields.Count
    Dim QTRangeAddress As String
    QTRangeAddress = OutputRange.Address(External:=True)
    Dim QTRange As Excel.Range
    '@Ignore ImplicitActiveSheetReference: Fully qualified range object is expected
    Set QTRange = Range(QTRangeAddress)
    QTRange.Resize(1, FieldsCount).EntireColumn.Clear
    '@Ignore ImplicitActiveSheetReference: Fully qualified range object is expected
    Set QTRange = Range(QTRangeAddress)
    
    Dim WSQueryTable As Excel.QueryTable
    For Each WSQueryTable In QTs
        WSQueryTable.Delete
    Next WSQueryTable
    
    Dim NamedRange As Excel.Name
    For Each NamedRange In QTRange.Worksheet.Names
        NamedRange.Delete
    Next NamedRange
    
    Set WSQueryTable = QTs.Add(Connection:=rst, Destination:=QTRange.Range("A1"))
    With WSQueryTable
        .FieldNames = True
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .EnableEditing = True
    End With
    WSQueryTable.Refresh
    '@Ignore IndexedDefaultMemberAccess
    QTRange.Worksheet.UsedRange.Rows(1).HorizontalAlignment = xlCenter
    
    '''' The same recordset object cannot be reused on the same worksheet:
    '''' outputs headers only, but no data. The source of the issue is not clear.
    '''' If this.DataQT is not set, set it. If set, update the reference and copy
    '''' the data (as a workaround).
    If Not this.DataQT Is Nothing Then
        rst.MoveFirst
        WSQueryTable.ResultRange.Range("A2").CopyFromRecordset rst
    End If
    WSQueryTable.ResultRange.CurrentRegion.Columns.AutoFit
    
    Set this.DataQT = WSQueryTable
    Set RecordsetToQT = this.DataQT
End Function


'@Description "Sets AdoCommand as to AdoRecordset.Source in preparation for .OpenXXX"
Friend Sub SetSource( _
            ByVal SQL As String, _
            ParamArray ADODBParamsValues() As Variant)
    Dim localArgs() As Variant
    localArgs = UnfoldParamArray(ADODBParamsValues)
    If AdoRecordset.State <> adStateClosed Then AdoRecordset.Close
    Set AdoRecordset.Source = this.cmd.AdoCommand(SQL, localArgs)
End Sub


Private Function IDbRecordset_RecordsetToQT(ByVal OutputRange As Excel.Range) As Excel.QueryTable
    Set IDbRecordset_RecordsetToQT = RecordsetToQT(OutputRange)
End Function


Private Property Get IDbRecordset_cmd() As IDbCommand
    Set IDbRecordset_cmd = this.cmd
End Property


Private Property Get IDbRecordset_AdoRecordset() As ADODB.Recordset
    Set IDbRecordset_AdoRecordset = AdoRecordset
End Property


Private Function IDbRecordset_GetAdoRecordset( _
            ByVal SQL As String, _
            ParamArray ADODBParamsValues() As Variant) As ADODB.Recordset
    Dim localArgs() As Variant
    localArgs = UnfoldParamArray(ADODBParamsValues)
    SetSource SQL, localArgs
    Set IDbRecordset_GetAdoRecordset = AdoRecordset
End Function


' Execute and ExecuteScalar can be combined into one method returning Variant, where distinction
' is made based on the AdoRecordset.MaxRecords value (1 - Scalar, regular otherwise)
Private Function IDbRecordset_OpenRecordset( _
            ByVal SQL As String, _
            ParamArray ADODBParamsValues() As Variant) As ADODB.Recordset
    Dim localArgs() As Variant
    localArgs = UnfoldParamArray(ADODBParamsValues)
    SetSource SQL, localArgs
    
    On Error GoTo RecordsetOpenError
    With AdoRecordset
        .MaxRecords = 0
        .Open Options:=this.OpenOptions
        If .CursorLocation = adUseClient Then Set .ActiveConnection = Nothing
    End With
    On Error GoTo 0
    Set IDbRecordset_OpenRecordset = AdoRecordset
    Exit Function
    
RecordsetOpenError:
    Err.Raise Err.Number, _
              Err.Source, _
              "IDbRecordset->OpenRecordset->AdoRecordset.Open: " & Err.Description, _
              Err.HelpFile, _
              Err.HelpContext
End Function


Private Function IDbRecordset_OpenScalar( _
            ByVal SQL As String, _
            ParamArray ADODBParamsValues() As Variant) As Variant
    Dim localArgs() As Variant
    localArgs = UnfoldParamArray(ADODBParamsValues)
    SetSource SQL, localArgs
        
    On Error GoTo RecordsetOpenError
    With AdoRecordset
        .MaxRecords = 1
        .Open Options:=this.OpenOptions
        If .CursorLocation = adUseClient Then Set .ActiveConnection = Nothing
    End With
    On Error GoTo 0
    
    IDbRecordset_OpenScalar = AdoRecordset.Fields.Item(0).Value
    Exit Function

RecordsetOpenError:
    Err.Raise Err.Number, _
              Err.Source, _
              "DbRecordset->IDbRecordset_OpenScalar->AdoRecordset.Open: " & Err.Description, _
              Err.HelpFile, _
              Err.HelpContext
End Function


'''' Updates record values
''''
'''' Args:
''''   AbsolutePosition (Long):
''''     Recordset.AbsolutePosition identifying the target record
''''
''''   ValuesDict (Dictionary):
''''     FieldName -> Value map
''''
'@Description "Updates modified records"
Private Sub IDbRecordset_UpdateRecord( _
            ByVal AbsolutePosition As Long, _
            ByVal ValuesDict As Scripting.Dictionary)
    Dim NumRecords As Long
    
    With AdoRecordset
        Guard.NullReference ValuesDict
        Guard.ExpressionErr .LockType = adLockBatchOptimistic, _
                            AdoFeatureNotAvailableErr, _
                            "DbRecordset", _
                            "Set LockType = adLockBatchOptimistic"
        Guard.ExpressionErr .State = adStateOpen, _
                            IncompatibleStatusErr, _
                            "DbRecordset", _
                            "Expected AdoRecordset.Status = adStateOpen"
        '@Ignore ValueRequired: false positive
        Guard.ExpressionErr AbsolutePosition <= .RecordCount, _
                            InvalidParameterErr, _
                            "DbRecordset", _
                            "AbsolutePosition must be <= AdoRecordset.RecordCount"
        
        '@Ignore ValueRequired: False positive
        NumRecords = AbsolutePosition - .AbsolutePosition
        '@Ignore ArgumentWithIncompatibleObjectType: False positive
        .Move NumRecords
        
        Dim FieldName As Variant
        For Each FieldName In ValuesDict.Keys
            '@Ignore ImplicitDefaultMemberAccess, IndexedDefaultMemberAccess
            .Fields(FieldName) = ValuesDict(FieldName)
        Next FieldName
    End With
End Sub


'@Description "Updates AdoRecordset data in preparation for a database update"
Friend Sub UpdateRecordsetData(ByRef AbsolutePositions() As Long, _
                               ByRef RecordsetData() As Variant)
    Dim FieldCount As Long
    FieldCount = UBound(RecordsetData, 2) - LBound(RecordsetData, 2) + 1
    Dim RecordCount As Long
    RecordCount = UBound(RecordsetData, 1) - LBound(RecordsetData, 1) + 1
    
    Guard.ExpressionErr AdoRecordset.Fields.Count = FieldCount, _
                        IncompatibleArraysErr, "DbRecordset", _
                        "Field count mismatch"
    '@Ignore ValueRequired: false positive
    Guard.ExpressionErr AdoRecordset.RecordCount = RecordCount, _
                        IncompatibleArraysErr, "DbRecordset", _
                        "Record count mismatch"
    Guard.ExpressionErr LBound(RecordsetData, 1) = 1, IncompatibleArraysErr, _
                        "DbRecordset", "Records dimension should be 1-based"
    Guard.ExpressionErr LBound(RecordsetData, 2) = 1, IncompatibleArraysErr, _
                        "DbRecordset", "Fields dimension should be 1-based"
    Guard.ExpressionErr AbsolutePositions(UBound(AbsolutePositions)) <= RecordCount, _
                        SubscriptOutOfRange, "DbRecordset", _
                        "Record position out of range"

    Dim RecordPos As Long  '''' Current AbsolutePosition
    Dim FieldIndex As Long
    Dim RecordPosIndex As Long '''' Index of AbsolutePosition in dirty records
    Dim NumRecords As Long '''' Relative cursor shift for the .Move method
    
    '''' Initialize RecordPos to current recordset position. Since setting
    '''' the .AbsolutePosition attribute directly invalidates cache, use
    '''' this value to calculate relative shift for the .Move method
    AdoRecordset.MoveFirst
    '@Ignore ValueRequired: false positive
    RecordPos = AdoRecordset.AbsolutePosition
    '''' Loop through the list of dirty record indices
    For RecordPosIndex = LBound(AbsolutePositions) To UBound(AbsolutePositions)
        NumRecords = AbsolutePositions(RecordPosIndex) - RecordPos
        RecordPos = AbsolutePositions(RecordPosIndex)
        '@Ignore ArgumentWithIncompatibleObjectType: False positive
        AdoRecordset.Move NumRecords
        '''' Update field values
        For FieldIndex = 1 To FieldCount
            '@Ignore ImplicitDefaultMemberAccess, IndexedDefaultMemberAccess
            AdoRecordset.Fields(FieldIndex - 1) = RecordsetData(RecordPos, FieldIndex)
        Next FieldIndex
    Next RecordPosIndex
End Sub


'@Description "Executes transaction-wrapped batch update of the recordset."
Friend Sub PersistRecordsetChanges(ByVal DirtyRecordCount As Long)
    With AdoRecordset
        Guard.ExpressionErr .State = adStateOpen, _
                            IncompatibleStatusErr, _
                            "DbRecordset", _
                            "Expected AdoRecordset.Status = adStateOpen"
                            
        Dim db As IDbConnection
        Set db = this.cmd.Connection
        '''' Marshal dirty records only
        .MarshalOptions = adMarshalModifiedOnly
        Set .ActiveConnection = this.cmd.Connection.AdoConnection
        On Error GoTo Rollback
        '''' Set the expected count of affected rows in the DbConnection object
        db.ExpectedRecordsAffected = DirtyRecordCount
        '''' Wrap update in a transaction
        db.BeginTransaction
        .UpdateBatch
        db.CommitTransaction
        On Error GoTo 0
        If .CursorLocation = adUseClient Then Set .ActiveConnection = Nothing
    End With
    
    Exit Sub
    
Rollback:
    this.cmd.Connection.RollbackTransaction
    With Err
        .Raise .Number, .Source, .Description, .HelpFile, .HelpContext
    End With
End Sub


'''' Args:
''''   AbsolutePositions (1D array of long):
''''     A 1D 1-based array containing absolute positions of dirty records in
''''     the recordset object (as in AdoRecordset.AbsolutePosition). The caller
''''     should sort it in ascending order
''''
''''   RecordsetData (2D variant array):
''''     2D record-wise 1-based array of recordset data
''''
'@Description "Updates recordset data from 2D array of field values and an array of dirty record indices"
Private Sub IDbRecordset_UpdateRecordset(ByRef AbsolutePositions() As Long, _
                                         ByRef RecordsetData() As Variant)
    UpdateRecordsetData AbsolutePositions, RecordsetData
    Dim DirtyRecordsCount As Long
    DirtyRecordsCount = UBound(AbsolutePositions) - LBound(AbsolutePositions) + 1
    PersistRecordsetChanges DirtyRecordsCount
End Sub

---

SecureADODB.Examples.ExamplesDbRecordsetUpdate.SQLiteUpdateRstTransactionChangesTest contains demo code, which retrieves sample data from a mock SQLite database into a recordset, modifies it, updates the database, and restores the original data (see Excel file in the repo; SQLite ODBC driver must be installed).

Affected rows count

Verifying the affected rows count is a convenient and efficient consistency check. UpdateRecordset method takes a 1D array containing ids of dirty records. Therefore, the expected value for the number of affected rows is readily available. It appears, however, that the actual number is not available from the recordset object, necessitating the use of backend-specific sources.

In SQLite, SELECT total_changes() query returns the total number of changes for the Connection object used. If executed before and after the transaction wrapping the UpdateBatch call, it yields the number of rows changed by the database engine during the transaction. For it to work correctly, this query must share the Connection object with UpdateBatch and transaction-related commands. The first call (from the BeginTransComplete handler) caches the reference value in the TransRecordsAffected attribute (the ExecuteComplete handler sets a similar RecordsAffected variable). The second call (from the CommitTransComplete) yields the desired value and verifies that it matches the expected count.

Two additional DbConnection attributes (Engine and cmdAffectedRows) help streamline this engine-specific solution. Engine setter initializes both of these attributes when the DbManager.CreateFileDb factory sets Engine to its first argument, DbType. cmdAffectedRows is an ADODB.Command object set to retrieve the total changes count. Connection event handlers, in turn, call the TotalChanges function, which executes the cmdAffectedRows command and returns affected rows count or -1 if this feature is unavailable.

Relevant sections of the DbConnection class mentioned above:

Option Explicit
Implements IDbConnection

Private WithEvents AdoConnection As ADODB.Connection
Private Type TDbConnection
    ExecuteStatus As ADODB.EventStatusEnum
    RecordsAffected As Long
    TransactionsDisabled As Boolean
    HasActiveTransaction As Boolean
    LogController As ILogger
    TransRecordsAffected As Long
    ExpectedRecordsAffected As Long
    cmdAffectedRows As ADODB.Command
    Engine As String
End Type
Private this As TDbConnection

'@Description "If possible, queries the database for total changes count."
Friend Function TotalChanges() As Long
    TotalChanges = -1
    If Not this.cmdAffectedRows Is Nothing Then
        On Error Resume Next
        TotalChanges = this.cmdAffectedRows.Execute.Fields.Item(0).Value
        On Error GoTo 0
    End If
End Function

'================================================================================'
'============================ IDbConnection INTERFACE ==========================='
'================================================================================'

'@Description "Set database type [typically recieved from the manager]"
Private Property Let IDbConnection_Engine(ByVal EngineName As String)
    this.Engine = EngineName
    '''' Set engine specific command for querying affected rows count
    If LCase$(EngineName) = "sqlite" Then
        '''' Set command for the SQLite engine
        Set this.cmdAffectedRows = New ADODB.Command
        With this.cmdAffectedRows
            .CommandType = adCmdText
            .Prepared = True
            .CommandText = "SELECT total_changes()"
            Set .ActiveConnection = AdoConnection
        End With
    End If
End Property

'================================================================================'
'========================= AdoConnection EVENT HANDLERS ========================='
'================================================================================'

Private Sub AdoConnection_BeginTransComplete( _
            ByVal TransactionLevel As Long, _
            ByVal pError As ADODB.Error, _
            ByRef adStatus As ADODB.EventStatusEnum, _
            ByVal pConnection As ADODB.Connection)
    this.TransRecordsAffected = TotalChanges()
End Sub

Private Sub AdoConnection_CommitTransComplete( _
            ByVal pError As ADODB.Error, _
            ByRef adStatus As ADODB.EventStatusEnum, _
            ByVal pConnection As ADODB.Connection)
    With this
        .TransRecordsAffected = TotalChanges() - .TransRecordsAffected
        If .ExpectedRecordsAffected >= 0 Then
            Guard.Expression .ExpectedRecordsAffected = .TransRecordsAffected, _
                    "DbConnection", "Affected rows count mismatch"
            Debug.Print "Affected rows count (matched): " & CStr(.TransRecordsAffected)
        Else
            Debug.Print "Affected rows count: " & CStr(.TransRecordsAffected)
        End If
        .ExpectedRecordsAffected = -1
    End With
End Sub

---

DbManager.CreateFileDb

Public Function CreateFileDb( _
                 ByVal DbType As String, _
        Optional ByVal DbFileName As String = vbNullString, _
        Optional ByVal ConnectionOptions As String = vbNullString, _
        Optional ByVal LoggerType As LoggerTypeEnum = LoggerTypeEnum.logGlobal _
        ) As IDbManager
    Dim LogController As ILogger
    Select Case LoggerType
        Case LoggerTypeEnum.logDisabled
            Set LogController = Nothing
        Case LoggerTypeEnum.logGlobal
            Set LogController = Logger
        Case LoggerTypeEnum.logPrivate
            Set LogController = Logger.Create
    End Select
    
    '''' CSV fails if String -> adVarWChar mapping is used
    ''''              String -> adVarChar must be used for CSV instead
    Dim provider As IDbParameters
    Set provider = DbParameters.Create( _
            IIf(LCase$(DbType) <> "csv", AdoTypeMappings.Default, AdoTypeMappings.CSV))
    
    Dim baseCommand As IDbCommandBase
    Set baseCommand = DbCommandBase.Create(provider)
    
    Dim Factory As IDbCommandFactory
    Set Factory = DbCommandFactory.Create(baseCommand)
    
    Dim DbConnStr As DbConnectionString
    Set DbConnStr = DbConnectionString.CreateFileDb(DbType, DbFileName, , ConnectionOptions)
    Dim db As IDbConnection
    Set db = DbConnection.Create(DbConnStr.ConnectionString, LogController)
    db.Engine = DbType
    
    Dim Instance As DbManager
    Set Instance = DbManager.Create(db, Factory, LogController)
    Instance.InitExtra DbConnStr
    
    Set CreateFileDb = Instance
End Function

---

Answer 1

Some ADODB pointers

Querying the data

Keep in mind that a query may return an empty recordset. OpenScalar accesses the first record without any checks. Verify that RecordCount > 0 (CSV backend, for example, ignores the MaxRecords attribute, so the recordset returned by OpenScalar may have RecordCount > 1 even if MaxRecords = 1) and that AbsolutePosition is usable (possibly use MoveFirst explicitly). If RecordCount = 0, perhaps, return Empty/Null.

Updating client-side recordset data

Recordset update routines, transferring changes from the client’s buffer to the recordset object, rely on the AbsolutePosition attribute.

1. Consider adding Guard clauses to ensure that the Filter attribute is set to adFilterNone.
2. Whenever the AbsolutePosition attribute is not set within a routine directly or indirectly (e.g., via the MoveXXX methods) before the first use, check that it does not point to adPosUnknown, adPosBOF, or adPosEOF. If so, reset it appropriately.

Updating the database

1. UpdateRecord should accept LockType = adLockOptimistic as well.
2. UpdateRecordsetData should have a Guard checking for LockType = adLockBatchOptimistic.
3. Check the ActiveConnection.Errors collection immediately after UpdateBatch in the batch mode (LockType = adLockBatchOptimistic) and after Update in the immediate mode (LockType = adLockOptimistic for client-side cursor).
4. Consider exposing PersistRecordsetChanges on the IDbRecordset interface. Since the Recordset attribute is exposed, the user may choose to update the recordset directly. PersistRecordsetChanges would then update the database.