So I had some legacy code that was testing an mdb connection to make sure it could get an exclusive lock on the file. If so, the code would then proceed doing an update procedure, but switched methods to use ADO.

I am pretty certain that I wrote the code like 15 years ago when Microsoft had announced (and since renigged) that DAO was going away and ADO was going to replace it.

In any case, I had upgraded the Dbs to use ACCDB backends. This seems to have some “enhanced” functionality that allows you to open a database in exclusive mode even when others are in the database and so when I made the code live, multiple people in the database wreaked havoc on the routine and there had already been 2 instances where a table had been deleted and not recreated causing even more problems.

So, what was I going to do to get this working? I thought I would use a transaction to do the whole update process.

A transaction is something that allows you to try to do various SQL commands and if you get an error, you can programmatically “rollback” the commands. As if you never even started the process to begin with. And otherwise you can commit the transaction.to finalize it. This worked perfectly to prevent the process from trashing the database. here are the relevant sections of the function I rewrote:

Private Sub UpdateAll() 
    Dim WS As Workspace 
    Dim beDB As DAO.Database 
    Dim curDB As DAO.Database 
    Dim strBeDB As String 
    Dim I As Integer 
    Me.cmdDone.Enabled = False 
    DoCmd.Hourglass True 
    DoCmd.SetWarnings False 
    Set WS = DBEngine(0) 
    On Error GoTo ResumeOnError 
    strBeDB = AJSopt.AJS_BackEndDB_Path &  "\EakasGold_PlannedReqData.accdb"
    'Try to open the backend Exclusively
    Set beDB = WS.OpenDatabase(AJSopt.AJS_BackEndDB_Path &  "\EakasGold_PlannedReqData.accdb",True) 
    If beDB Is Nothing Then 
        'We could not get exclusive access
        MsgBox  "You need to have exclusive access to the database to run this Update.  Please make sure no one else is in Planned Requirements and try again."
        GoTo Exit_Sub 
    End If 
    Set curDB = WS(0) 
    On Error GoTo LogErrorAndAlertUser 
    WS.BeginTrans 
        'March weekly records up a week in the forecast table.
        Dim rsForecast As DAO.Recordset 
        Dim OldDate As Date 
        Dim NewDate As Date 
        OldDate = NiceDLookup( "ForecastStartDate", "Status") 
        NewDate = DateAdd( "ww",9,DateAdd( "d",1 - Weekday(Date),Date)) 
        curDB.Execute _ 
            "UPDATE Status SET ForecastStartDate = #" & NewDate &  "#"  'DateAdd( ""ww "" ,9 ,DateAdd( ""d "" ,1-Weekday(Date()) ,Date()))" 
        'Need to add code to change numbers in extForecast table if the ForecastStartDate has changed
        If DateDiff( "ww",OldDate,NewDate) > 0 Then 
            Dim numWeeks As Double 
            numWeeks = DateDiff( "ww",OldDate,NewDate) 
            For I = 9 To 39 - numWeeks 
                curDB.Execute ( "UPDATE ExtForecast SET Week" & I &  " = Week" & (I + numWeeks)) 
            Next I 
            For I = 39 - numWeeks + 1 To 39 
                curDB.Execute ( "UPDATE ExtForecast SET Week" & I &  " = 0") 
            Next I 
            'CurrentProject.Connection.Execute ("UPDATE ExtForecast SET Week0 = 0")
            WS.CommitTrans 
            WS.BeginTrans 
        End If 
    'Continue with update routine
        'Formerly query AddNewFamiliesToExtForecast
        curDB.Execute _ 
            "INSERT INTO ExtForecast(FamilyNumber)" & _ 
            "SELECT FamilyData.FamilyNumber " & _ 
            "FROM FamilyData " & _ 
            "WHERE (((FamilyData.FamilyNumber) Not In (Select FamilyNumber From ExtForecast)));"
        Me.lblStep1.Caption =  "Done!"
        Me.Repaint 
        Call DeleteTable( "MasterPartList",beDB) 
        curDB.Execute CreateTableMasterPartList(),dbSeeChanges 
        curDB.Execute  "UPDATE tmpMasterPartList t INNER JOIN Defaults_CartonSize cs ON " & _ 
            "('E' = cs.LocationKey AND t.Itemkey = cs.ItemKey) " & _ 
            "SET t.Carton_Size = Val(Nz(cs.CartonSize,0))"
        curDB.Execute  "UPDATE tmpMasterPartList t INNER JOIN Defaults_LeadTime lt ON " & _ 
            "('E' = lt.LocationKey AND t.Itemkey = lt.ItemKey) " & _ 
            "SET t.Lead_Time = Val(Nz(lt.LeadTime,0))"
        curDB.Execute  "UPDATE tmpMasterPartList t INNER JOIN Defaults_SafetyStock ss ON " & _ 
            "('E' = ss.LocationKey AND t.Itemkey = ss.ItemKey) " & _ 
            "SET t.MinimumStockQty = Val(Nz(ss.SafetyStock,0))"
        curDB.Execute  "SELECT * INTO MasterPartList IN '" & strBeDB &  "' FROM tmpMasterPartList"
        curDB.Execute  "DROP TABLE tmpMasterPartList"
            WS.CommitTrans 
            WS.BeginTrans 
        Call DeleteTable( "Family_ShipsPlusForecast",beDB) 
        curDB.Execute CreateTableFamily_ShipsPlusForecast(),dbSeeChanges 
        curDB.Execute  "SELECT * INTO Family_ShipsPlusForecast IN '" & strBeDB &  "' FROM tmpFamily_ShipsPlusForecast"
        curDB.Execute  "DROP TABLE tmpFamily_ShipsPlusForecast"
            WS.CommitTrans 
            WS.BeginTrans 
        Me.lblStep2.Caption =  "Done!"
        Me.lblStep3.Caption =  "Running Query"
        Me.Repaint 
        Call DeleteTable( "FinalShipsPlusForecastPlusOrdered",beDB) 
        curDB.Execute CreateTableFinalShipsPlusForecastPlusOrdered(),dbSeeChanges 
        curDB.Execute  "SELECT * INTO FinalShipsPlusForecastPlusOrdered IN '" & strBeDB &  "' FROM tmpFinalShipsPlusForecastPlusOrdered"
        curDB.Execute  "DROP TABLE tmpFinalShipsPlusForecastPlusOrdered"
            WS.CommitTrans 
            WS.BeginTrans 
        Me.lblStep3.Caption =  "Done!"
        Me.Repaint 
        
        Me.lblStep6.Caption =  "Done!"
        Me.Repaint 
        Dim rsInvMast As DAO.Recordset 
        Dim nextVal As Double 
        Dim arrInvMast As Variant 
        Set rsInvMast = curDB.OpenRecordset( "SELECT Trim(ItemKey),Nz(Qtyonhand,0) FROM MasterPartList ORDER BY ItemKey",_ 
            dbOpenSnapshot,dbSeeChanges,dbPessimistic) 
        'rsInvMast.MoveLast
        arrInvMast = rsInvMast.GetRows(rsInvMast.RecordCount) 
        rsInvMast.Close 
        Set rsInvMast = Nothing 
        Set rsForecast = curDB.OpenRecordset( "SELECT * FROM FinalShipsPlusForecastPlusOrdered ORDER BY ShippingDate ASC",_ 
            dbOpenDynaset,dbSeeChanges,dbPessimistic) 
        For I = 0 To UBound(arrInvMast,2) 
            DoEvents     ' Let any system events do their thing, otherwise the form display
                        ' code doesn't function properly
'            If I Mod 200 = 0 Then
'                rsForecast.Close
'                Set rsForecast = curDB.OpenRecordset("SELECT * FROM FinalShipsPlusForecastPlusOrdered ORDER BY ShippingDate ASC", _
'                    dbOpenDynaset, dbSeeChanges, dbPessimistic)
'            End If
            Me.lblStep4.Caption = (I + 1) &  " of " & (UBound(arrInvMast,2) + 1) 
            Me.Repaint 
            ' Filter the recordset using each itemkey from our database
            rsForecast.Filter =  "ItemKey = '" & arrInvMast(0,I) &  "'"
            If Not rsForecast.BOF And Not rsForecast.EOF Then 
            rsForecast.MoveFirst 
            rsForecast.Edit 
            rsForecast!OnHandQuantity = arrInvMast(1,I) 
            nextVal = rsForecast!OnHandQuantity - IIf(IsNull(rsForecast!RequiredQuantity),0,rsForecast!RequiredQuantity) + rsForecast!OrderedQuantity 
            rsForecast.Update 
            rsForecast.MoveNext 
            Do While Not rsForecast.EOF 
                rsForecast.Edit 
                rsForecast![OnHandQuantity] = nextVal 
                nextVal = rsForecast!OnHandQuantity - IIf(IsNull(rsForecast!RequiredQuantity),0,rsForecast!RequiredQuantity) + rsForecast!OrderedQuantity 
                rsForecast.Update 
                rsForecast.MoveNext 
            Loop 
            End If 
        Next 
        rsForecast.Close 
        Me.lblStep4.Caption =  "Done!"
        ' Update the Master part list with the requirements we just loaded
        curDB.Execute _ 
            "UPDATE MasterPartList AS mpl, FinalShipsPlusForecastPlusOrdered AS a " & _ 
            "SET Requirements = Nz(Requirements,0)+Nz(RequiredQuantity,0), " & _ 
            "QtyOnOrder = Nz(QtyOnOrder,0)+Nz(OrderedQuantity,0) " & _ 
            "WHERE a.ItemKey=mpl.ItemKey"
        Me.lblStep5.Caption =  "Done!"
        curDB.Execute _ 
            "UPDATE Status SET LastUpdated = Now()"
        WS.CommitTrans 
    GoTo Exit_Sub 
ResumeOnError: 
    AJS.GblErrHandler Action:= "INFO",MsgAction:= "LOGONLY"
    Resume Next 
LogErrorAndAlertUser: 
    'Stop
    'Resume
    WS.Rollback 
    AJS.GblErrHandler Action:= "RETURN",MsgAction:= "LOGONLY"
    MsgBox  "Update Failed, make sure no one is using the MRP application and try again."
    Resume Exit_Sub 
Exit_Sub: 
    If Not beDB Is Nothing Then beDB.Close 
    Set beDB = Nothing: Set WS = Nothing: Set curDB = Nothing 
    Forms!frmMain.lblLastUpdate.Requery 
    Forms!frmMain.Disclaimer.Visible = IIf(Forms!frmMain.LastUpdated >= Forms!frmMain.LastChange,False,True) 
    Forms!frmMain.Dirty = False 
    Me.cmdDone.Enabled = True 
    DoCmd.Hourglass False 
    DoCmd.SetWarnings True 
End Sub 

Actually, there it is in it’s entirety. I’d like to point out that I am at certain points committing the transaction and then restarting it with WS.CommitTrans and WS.BeginTrans. This attempts to commit all the changes up to that point on all databases in that workspace. I used Workspace(0) to set my WS variable which is the current workspace. This meant that any error logging I was doing was potentially getting rolled back if the transaction never finished because CurrentDb is actually Workspace(0)(0) and therefore was included in the transaction and could be rolled back if it was never committed.

I have two error handling subs, the first one to handle an expected potential error that will prevent the routine from working at all, and then the second one to rollback the transaction and alert the user to the failure and exit the sub after cleaning up after itself.

Ultimately, it was quite easy to make the references to the databases part of the Workspace variable and then simply use StartTrans, CommitTrans, and Rollback at the appropriate places to prevent unwanted changes to the database.