Pessimistic Locking with Access ADO and SQL Server

Public Function GetNextCostNumber(strNextNumberName As String, _
                              booIncrementNextNumber As Boolean) As Variant
    
    '******************************************************************************
    'This function will be called from various forms.
    'It carries out the following tasks:-
    '   (a) Picks up the required "Next Number" from the "Next Cost Numbers" table.
    '   (b) Sets the return value to the retrieved "Next Number".
    '   (c) If specified, increments the specified "Next Number"  in the
    '       "Next Cost Numbers" table.
    '******************************************************************************
    
    '=========================
    'Switch on error trapping.
    '=========================
    On Error GoTo ErrHandler
    
    '=============================================================================
    'Set pointer to hourglass to make sure user knows the routine is active if the lock takes a while to establish
    '=============================================================================
'    DoCmd.Hourglass True
 
    '========================================
    'Declare variables for the error handler.
    '========================================
    Dim intLockCount As Integer
    Dim intChoice As Integer
    Dim intRndCount As Integer
    Dim intI As Integer
 
    '=======================================================================
    'Retrieve the specified "Next Number" from the "Next Cost Numbers" table
    'and, if specified, increment the specified "Next Number" in the
    '"Next Cost Numbers" table.
    '=======================================================================
    Dim cnn1 As ADODB.Connection
    Set cnn1 = New ADODB.Connection
    Dim rst As ADODB.Recordset
    Set rst = New ADODB.Recordset
    Dim strSQL As String
    
    cnn1.ConnectionTimeout = 5
    cnn1.ConnectionString = gstrConnect
    cnn1.CursorLocation = adUseServer
    cnn1.Open
    
    cnn1.BeginTrans
    
    strSQL = "SELECT * FROM tblNextCostNumbers " & _
                    "WHERE NextCostNumbersID = 1"
                    
   
    rst.CursorLocation = adUseServer
    rst.CursorType = adOpenKeyset
    rst.LockType = adLockPessimistic
        
    rst.Open strSQL, cnn1, adOpenKeyset, adLockPessimistic
    
    '------------------------------------------------------------------------
    'This will throw a timeout error if the recordset is locked
    '------------------------------------------------------------------------
    rst.MoveFirst
    
    If Not rst.EOF Then
        If rst.RecordCount = 0 Then
            MsgBox "UNEXPECTED ERROR - The application could not find a" & _
                   " 'Next Cost Numbers' record in the 'Next Cost Numbers'" & _
                   " reference table.", _
                   vbOKOnly, "UNEXPECTED ERROR"
            GoTo LeaveSub
    
        Else
    
            'Get the specified "Next Number" and, if requested, increment
            'the specified "Next Number".
            Select Case strNextNumberName
                
                Case "PO"
                    GetNextCostNumber = rst!NextPurchaseOrderNo
                    
                    'If requested, increment the "Next Purchase Order Number".
                    If booIncrementNextNumber Then
                        rst!NextPurchaseOrderNo = rst!NextPurchaseOrderNo + 1
                    End If
                
                Case "HO"
                    GetNextCostNumber = rst!NextHireOrderNo
                    
                    'If requested, increment the "Next Hire Order Number".
                    If booIncrementNextNumber Then
                        rst!NextHireOrderNo = rst!NextHireOrderNo + 1
                    End If
                
                Case "ActualCostReportNo"
                    GetNextCostNumber = rst!NextActualCostReportNo
                    
                    'If requested, increment the "Next Actual Cost Report Number".
                    If booIncrementNextNumber Then
                        rst!NextActualCostReportNo = rst!NextActualCostReportNo + 1
                    End If
                
                Case "ReconciliationReportNo"
                    GetNextCostNumber = rst!NextReconciliationReportNo
                    
                    'If requested, increment the "Next Reconciliation Report Number".
                    If booIncrementNextNumber Then
                        rst!NextReconciliationReportNo = rst!NextReconciliationReportNo + 1
                    End If
                    
                Case "Mentor Recon"
                    GetNextCostNumber = rst!NextMentorReconRptNo
                    
                    'If requested, increment the "Next Reconciliation Report Number".
                    If booIncrementNextNumber Then
                        rst!NextMentorReconRptNo = rst!NextMentorReconRptNo + 1
                    End If
                
                Case "Daily Timesheet Items"
                    GetNextCostNumber = rst!NextId_DailyTimesheetItems
                    
                    'If requested, increment the "Next Id - Daily Timesheet Items".
                    If booIncrementNextNumber Then
                        rst!NextId_DailyTimesheetItems = rst!NextId_DailyTimesheetItems + 1
                    End If
                
                Case "Daily Timesheets"
                    GetNextCostNumber = rst!NextId_DailyTimesheets
                    
                    'If requested, increment the "Next Id - Daily Timesheet Items".
                    If booIncrementNextNumber Then
                        rst!NextId_DailyTimesheets = rst!NextId_DailyTimesheets + 1
                    End If
               
                Case "Financial Statuses Change History"
                    GetNextCostNumber = rst!NextId_FinancialStatusesChangeHistory
                    
                    'If requested, increment the "Next Id - Daily Timesheet Items".
                    If booIncrementNextNumber Then
                        rst!NextId_FinancialStatusesChangeHistory = rst!NextId_FinancialStatusesChangeHistory + 1
                    End If
                 
                Case "HO Items"
                    GetNextCostNumber = rst!NextId_HOItems
                    
                    'If requested, increment the "Next Id - HO Items".
                    If booIncrementNextNumber Then
                        rst!NextId_HOItems = rst!NextId_HOItems + 1
                    End If
                
                Case "Non Job Invoice Items"
                    GetNextCostNumber = rst!NextId_NonJobInvoiceItems
                    
                    'If requested, increment the "Next Id - Non Job Invoice Items".
                    If booIncrementNextNumber Then
                        rst!NextId_NonJobInvoiceItems = rst!NextId_NonJobInvoiceItems + 1
                    End If
               
                Case "Non Job Invoices"
                    GetNextCostNumber = rst!NextId_NonJobInvoices
                    
                    'If requested, increment the "Next Id - Non Job Invoices".
                    If booIncrementNextNumber Then
                        rst!NextId_NonJobInvoices = rst!NextId_NonJobInvoices + 1
                    End If
               
                Case "Payroll Batches"
                    GetNextCostNumber = rst!NextId_PayrollBatches
                    
                    'If requested, increment the "Next Id - Payroll Batches".
                    If booIncrementNextNumber Then
                        rst!NextId_PayrollBatches = rst!NextId_PayrollBatches + 1
                    End If
                
                Case "PO Items"
                    GetNextCostNumber = rst!NextId_POItems
                    
                    'If requested, increment the "Next Id - PO Items".
                    If booIncrementNextNumber Then
                        rst!NextId_POItems = rst!NextId_POItems + 1
                    End If
                
                Case "Standard Credit Note Items"
                    GetNextCostNumber = rst!NextId_StandardCreditNoteItems
                    
                    'If requested, increment the "Next Id - Standard Credit Note Items".
                    If booIncrementNextNumber Then
                        rst!NextId_StandardCreditNoteItems = rst!NextId_StandardCreditNoteItems + 1
                    End If
                
                Case "Standard Credit Notes"
                    GetNextCostNumber = rst!NextId_StandardCreditNotes
                    
                    'If requested, increment the "Next Id - Standard Credit Notes".
                    If booIncrementNextNumber Then
                        rst!NextId_StandardCreditNotes = rst!NextId_StandardCreditNotes + 1
                    End If
                
                Case "Standard Invoice Items"
                    GetNextCostNumber = rst!NextId_StandardInvoiceItems
                    
                    'If requested, increment the "Next Id - Standard Invoice Items".
                    If booIncrementNextNumber Then
                        rst!NextId_StandardInvoiceItems = rst!NextId_StandardInvoiceItems + 1
                    End If
                
                Case "Standard Invoices"
                    GetNextCostNumber = rst!NextId_StandardInvoices
                    
                    'If requested, increment the "Next Id - Standard Invoices".
                    If booIncrementNextNumber Then
                        rst!NextId_StandardInvoices = rst!NextId_StandardInvoices + 1
                    End If
                
                Case "Summary Timesheet Items"
                    GetNextCostNumber = rst!NextId_SummaryTimesheetItems
                    
                    'If requested, increment the "Next Id - Summary Timesheet Items".
                    If booIncrementNextNumber Then
                        rst!NextId_SummaryTimesheetItems = rst!NextId_SummaryTimesheetItems + 1
                    End If
                
                Case "Summary Timesheets"
                    GetNextCostNumber = rst!NextId_SummaryTimesheets
                    
                    'If requested, increment the "Next Id - Summary Timesheets".
                    If booIncrementNextNumber Then
                        rst!NextId_SummaryTimesheets = rst!NextId_SummaryTimesheets + 1
                    End If
                    
                Case "Requisition"
                    GetNextCostNumber = rst!NextId_Requisition
                    
                    'If requested, increment the "Next Id - Summary Timesheets".
                    If booIncrementNextNumber Then
                        rst!NextId_Requisition = rst!NextId_Requisition + 1
                    End If
                    
                Case "Requisition Item"
                    GetNextCostNumber = rst!NextId_RequisitionItem
                    
                    'If requested, increment the "Next Id - Summary Timesheets".
                    If booIncrementNextNumber Then
                        rst!NextId_RequisitionItem = rst!NextId_RequisitionItem + 1
                    End If
                
                Case "Materials Supplied by Wolseley"
                    GetNextCostNumber = rst!NextId_MaterialsSuppliedByWolseley
                    
                    'If requested, increment the "Next Id - Materials Supplied by Wolseley".
                    If booIncrementNextNumber Then
                        rst!NextId_MaterialsSuppliedByWolseley = rst!NextId_MaterialsSuppliedByWolseley + 1
                    End If
                
                Case Else
                    MsgBox "The 'Next Number Name' " & strNextNumberName & _
                           " is not recognised by the 'Get Next Cost Number' function.", _
                           vbOKOnly, "APPLICATION ERROR"
                    GetNextCostNumber = 0
                    GoTo LeaveSub
                    
            End Select
    
            'Update the retrieved "Next Numbers" record (Therby unlocking it).
            rst.Update
            
        End If
    End If
    
    rst.Close
    Set rst = Nothing
''    DoCmd.Hourglass False
 
    cnn1.CommitTrans
    
LeaveSub:
    Exit Function
 
ErrHandler:
    Select Case Err.Number
        
        Case 3197
            '============================================================================
            'Handle Error 3197 - Data in the record has changed since it was last opened.
            'Try to edit the record again.  This automatically refreshes the record to
            'display the most recent data.
            '============================================================================
            Resume
    
        Case -2147467259
            '=========================================
            'Handle Error -2147467259 - The record is locked.
            '=========================================
            intLockCount = intLockCount + 1
            
            'If the lock error has already occurred three times.
            If intLockCount > 3 Then
    
                'Let the user cancel or retry.
                intChoice = MsgBox("The system has been unable to obtain a unique index number for " & _
                                                    strNextNumberName & _
                                                    ". This may be due to another user or process carrying out a large transaction " & _
                                                    "(such as a job download).  Either wait a couple of minutes and re-try or " & _
                                                    "cancel (cancelling will undo the changes you have made to this record. Do you wish to re-try or cancel save?", _
                                                     vbCritical + vbRetryCancel, "RETRY?")
        
                Select Case intChoice
                    Case vbCancel   'The user does not want to try again to obtain the lock.
                        GetNextCostNumber = 0
                        Resume LeaveSub
                    Case vbRetry  'The user wants to try again to obtain the lock.
                        intLockCount = 1
                End Select
        
            End If
    
            'Yield to windows.
            DoEvents
        
            'Delay a short random interval, making it longer each time the lock fails.
            intRndCount = intLockCount ^ 2 * Int(Rnd * 300 + 1000)
            For intI = 1 To intRndCount: Next intI
        
            'Try the edit again.
            Resume
 
        Case Else
            '=================
            'Report the error.
            '=================
            MsgBox "An unexpected error has occurred in the 'GetNextNumber' function.", _
                   vbOKOnly, "ERROR"
            MsgBox "ERROR: " & Err.Number & " " & Err.Description, vbOKOnly, "ERROR"
            GetNextCostNumber = 0
            Resume LeaveSub
    
    End Select
 
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338: