Ok, I finally got it... failproof...
With linked tables...
Open the recordset dbOpenDynaset, dbDenyWrite
Until this recordset is closed, any other attempts to open it produce error
3008 (laymans terms: the recordset is opened exclusively)
so wrap this in an incremented sleep loop with a timeout, trap the error, etc.
Here's the code... I've tested this every way I can think of and seems to
work great.
'==========START CODE==================
'Jack Leach 2009/09/23
'
'Gets the next increment of a custom autonumber
'
'Prevents multiple users from connected at once through the following:
' on a linked table, a recordset opened dbDynaset with the
' dbDenyWrite option, the recordset then cannot be re-opened until the
' first is closed. Error 3008 is trapped, sent to a timer and the
' process is repeated until the recordset is able to be opened or a
' timeout is reached.
'
'
'
'Autonumber table must contain only one field and one record or less
'The field datatype of the autonumber table must be Long Integer
'
'GetAutoNum returns string datatype, as all custom autonumers are stored
'in the db as strings
'
'Requires Sleep API (declared publicly in a seperate module, though
'can be declared privately in this module
Option Compare Database
Option Explicit
Public Enum eAutoNumbers
dsAutoNumPurchaseOrder = 0
dsAutoNumQuote = 1
dsAutoNumPackingSlip = 2
dsAutoNumInvoice = 3
End Enum
'==============================================================================
' NAME: GetAutoNum
' DESC: Retrieves the next Autonumber for the given type
' Returns String converted from the next numbe
'==============================================================================
'ErrStrV3.00
Public Function GetAutoNum(lANum As eAutoNumbers) As String
On Error GoTo Error_Proc
Dim Ret As String
'=========================
Dim sTable As String 'table to look up from
'=========================
'get data required to look up number
Select Case lANum
Case dsAutoNumPurchaseOrder
sTable = "tblANumPOs"
Case dsAutoNumQuote
sTable = "tblANumQuotes"
Case dsAutoNumPackingSlip
sTable = "tblANumPackSlips"
Case dsAutoNumInvoice
sTable = "tblANumInvoices"
End Select
Ret = pfGetNextNum(sTable)
'=========================
Exit_Proc:
If Len(Ret) = 0 Then
MsgBox "An unexpected error has occured while retrieving" & vbCrLf & _
"the next available number. Please try again" & vbCrLf & _
"and notify your Administrator if the problem persists." _
, vbCritical + vbOKOnly, "Error!"
End If
GetAutoNum = Ret
Exit Function
Error_Proc:
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: Module1, Procedure: GetAutoNum" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'==============================================================================
' NAME: pfGetNextNum
' DESC: gets the next increment from an autonumber table
' Returns ZLS on errors, table not availabl
'==============================================================================
'ErrStrV3.00
Private Function pfGetNextNum(TableName As String) As String
On Error GoTo Error_Proc
Dim Ret As String
'=========================
Const pcTimeOut = 3500 '3.5 seconds timeout
Const pcWaitIncr = 100 'wait increment between tries
Dim bDone As Boolean 'flag if the operation completed
Dim iCounter As Integer 'counter for intcrements
Dim lNextNum As Long 'next number
Dim rs As DAO.Recordset
'=========================
'explicitly initialize
bDone = False
iCounter = 0
lNextNum = 0
'loop while the done flag is false and the counter is under the TimeOut
While (Not bDone) And (iCounter < pcTimeOut)
On Error Resume Next
Set rs = CurrentDb.OpenRecordset(TableName, dbOpenDynaset, dbDenyWrite)
If Err.Number = 3008 Then 'rs is locked
'clear the error and reset handler
Err.Clear
On Error GoTo Error_Proc
Set rs = Nothing
'sleep the code and increment the counter
Sleep (pcWaitIncr)
iCounter = iCounter + pcWaitIncr
ElseIf Err <> 0 Then
'an actual error occured
GoTo Error_Proc
Else
'reset the handler
On Error GoTo Error_Proc
If rs.RecordCount = 0 Then
'no current records... start at 1
lNextNum = 1
With rs
.AddNew
rs(0) = lNextNum
.Update
End With
'flag that we're done here
bDone = True
Else 'there's an existing record
'current record availble, increment by 1
rs.MoveFirst
lNextNum = rs(0) + 1
With rs
.Edit
rs(0) = lNextNum
.Update
End With
'flag that we're done here
bDone = True
End If
'close rs
rs.Close
Set rs = Nothing
End If
Wend
'return ZLS on errors, 0 is nonvalid return...
Ret = IIf(lNextNum = 0, "", Trim(Str(lNextNum)))
'=========================
Exit_Proc:
pfGetNextNum = Ret
Exit Function
Error_Proc:
Ret = ""
Set rs = Nothing
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: Module1, Procedure: pfGetNextNum" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'============END CODE=============
--
Jack Leach
www.tristatemachine.com
"I haven''t failed, I''ve found ten thousand ways that don''t work."
-Thomas Edison (1847-1931)
). I will have to test