Why AutoNumber shouldn't be used in MultiUser databases (And How to ge the Unique Number)

In a multiuser database, it is possible to have two users attempt to add records to the database "at the same time". This will eventually cause an error "Duplicate value in Autonumber field". The simple way to avoid this issue is to generate your own "AutoNumber" value, using a seperate database/table which is "Locked" by the User until the value has been updated. The Locking of the database/Table is the Key. While one user has the database/table locked, no other user can access it to get a (duplicate) value. The function below, generates an "Autonumber" in this manner. This specific implementation is limited to 10,000 entries per month. This is due to the inclusion of the Year & Month being included as a "prefix" value to the serial integer value. Comments in the code show the areas where the Year & Month are included - so they may be easily removed for users wanting to have the simple incrementing integer.

MichaelRed
There is never time to do it right but there is always time to do it over.
Public Function NewQI_Num() As Long

'Submiitted to Tek-Tips.Com as Access FAQ on generating Unique ID numbers
'in a Multi-User database. This example Function was adapted from a commercial
'applilcation with approximatly 50 concurrent users and was in-service for over
'a year with out "Timing-Out" with the Retry value of 20.

'MichaelRed 8/15/2000.
'There is Never time to do it right but there is always time to do it over

On Error GoTo NewQiNum_Err

Dim MyDbs As Database 'Substitute Your Database Name Here
Dim BaseData As Recordset
Dim tblNewQiNum As Recordset
Dim qSelQiMax As Recordset

'Constants for the expected errors
Const RiErr = 3000
Const LockErr = 3260
Const InUseErr = 3262
Const NumReTries = 20# 'This is just a number of attempts
'we will make internally to this Function
'it is set to a nominal value, which works
'for moderate (~ 50 Users). It could be set
'to any arbitrary value, however the
'expectation it that it will NEVER Fail

'Variables for the Retry count
Dim NumLocks As Integer
Dim lngX As Long

'Variables used in the Code.
'Not that this implementation "wants" part of the Date (Year & Month)
' to be "Encoded" in the Unique Id, otherwise we could dispense with
'most of these vars - and there use/calculation below
Dim QiNum As Long
Dim lngOldQiNum As Long
Dim lngNewQiNum As Long
Dim lngBigQiNum As Long
Dim QiYear As Long
Dim QiMnth As String
Dim strQINum As String

'Remember to Use your DataBase Name
Set MyDbs = CurrentDb()
Set BaseData = MyDbs.OpenRecordset("Basic Data")

'Get the date part of the Id
QiYear = Format(Now, "yyyy")
QiMnth = Format(Now(), "mm")
strQINum = QiYear & QiMnth

'Get the Lowest possible value for an ID for the current Date
'This is a good place to remind everyone that all of the
'System (e.g. individual computer) Clocks MUST be synchronized!!!!
'the const vlaue (1000) is selected as a number >> the number of
'ID's we expect in the time period before Resetting the Prefix (e.g. Monthly)
QiNum = Val(strQINum) * 10000 'B

'For the convienience of readers the SQl from the Query is given
'Again, please be careful to use YOUR recordset (name)
'SELECT Max([Basic Data].Qi) AS Qi FROM [Basic Data];

'Get the Currently assigned Highest value. Again, this is only
'necessary because this implememtation 'wants the year & month in the Stamp
'Also, note the dbDenyRead. This assures us that - if we get access to the info,
'We have SOLE access to it. No one else can get past here untill we are done.
Set qSelQiMax = MyDbs.OpenRecordset("qSelQiMax", dbDenyRead)
Set tblNewQiNum = MyDbs.OpenRecordset("tblNewQiNum", dbDenyRead)

'tblNewQiNum has only two fields, [QiNum] & [QiDateTime].
'It only has a single record, so when we open the recordset, we are on
'the first record, and these values are immediatly available

'Again, this - except for the incrementing below - is just ot incorporate
'the Year and Month into the value as a Prefix.
lngOldQiNum = qSelQiMax!QI 'A
lngNewQiNum = tblNewQiNum!QiNum 'C
lngBigQiNum = lngNewQiNum 'Big = C (Assume C is the Answer)
If (lngOldQiNum > lngBigQiNum) Then 'IF (A >= Big) Then
lngBigQiNum = lngOldQiNum ' Big = A
End If 'End If

If (QiNum > lngBigQiNum) Then 'If (B >= Big) Then
lngBigQiNum = QiNum ' Big = B
End If 'End If

'Increment the ID
lngBigQiNum = lngBigQiNum + 1


'Update the Id value and (just for my own interest) the date/time stamp
With tblNewQiNum
.Edit
!QiNum = lngBigQiNum
!QiDateTime = Now()
.Update
End With
NewQI_Num = lngBigQiNum

NormExit:
Set BaseData = Nothing
Set MyDbs = Nothing

Exit Function 'Return

NewQiNum_Err:

'This is the part where we wait if another user is getting a New ID

'Check for the Expected errors
If ((Err = InUseErr) Or (Err = LockErr) Or (Err = RiErr)) Then

'If one of the expected ones, Increment the Counter
NumLocks = NumLocks + 1

If (NumLocks < NumReTries) Then 'Check for to many attempts
'Failing here probably indicates
'a system problem, not a real "TimeOut"

'We generate a pseudo random value to use in the empty loop
'it's really just a (pseudo) ramdom interval thinnnggggggyyyyyy
For lngX = 1 To NumLocks ^ 2 * Int(Rnd * 20 + 5)
DoEvents 'Wait in La-La land
Next lngX
Resume Next 'Go Back and Try Again
Else
'This should not happen. 20 Random retries should always
'get a unique number. But here is where the error handler would go
End If
Else
'Unexpected Error - Also known as "Tell me the Story, the old, old story ...
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbOKOnly & vbCritical, "Get Qi Number"
Go To NormExit
End If

End Function