Sub Exclusive_Link()
On Error Resume Next
Dim adoConn As ADODB.Connection
Dim adoRS As ADODB.Recordset
Dim lngRetries As Long
Set adoConn = New ADODB.Connection
Exclusive_Link_OpenConn:
lngRetries = lngRetries + 1
Debug.Print "loop: " & lngRetries
With adoConn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("User ID") = "Admin"
.Properties("Data Source") = [b]"C:\TestDB.mdb"[/b]
'This will open the DB for Exclusive access
.Properties("Mode") = [b]adModeShareExclusive[/b]
.Properties("Locale Identifier") = "1033"
.Properties("Persist Security Info") = False
.Properties("Jet OLEDB:System database") = "C:\SYSTEM.MDW"
.Properties("Jet OLEDB:Engine Type") = 5
.Properties("Jet OLEDB:Database Locking Mode") = 1
.Properties("Jet OLEDB:Global Partial Bulk Ops") = 2
.Properties("Jet OLEDB:Global Bulk Transactions") = 1
.Properties("Jet OLEDB:Create System Database") = False
.Properties("Jet OLEDB:Encrypt Database") = False
.Properties("Jet OLEDB:Don't Copy Locale on Compact") = False
.Properties("Jet OLEDB:Compact Without Replica Repair") = False
.Properties("Jet OLEDB:SFP") = False
.Open
End With
'Check to see if there was an error opening the connection
If Err.Number <> 0 Then
'check if there has been less than 50 attempts
If lngRetries < 50 Then
'Clear the errors and try again
Err.Clear
adoConn.Errors.Clear
GoTo Exclusive_Link_OpenConn
Else
MsgBox "Could not establish Exclusive link"
GoTo Exclusive_Link_Exit
End If
End If
'If you get here the connection was succesful
Set adoRS = New ADODB.Recordset
With adoRS
.Open [b]"SELECT * FROM Table1;"[/b], adoConn, adOpenDynamic, adLockOptimistic
'Create a new record
.AddNew
'Output the New autonumber to the immediate window
Debug.Print .Fields("ID")
'Save the newly created record
.Update
End With
Exclusive_Link_Exit:
On Error Resume Next
adoRS.Close
Set adoRS = Nothing
adoConn.Close
Set adoConn = Nothing
End Sub