Option Compare Database
Option Explicit

' From Access 2000 Developer's Handbook, Volume II
' by Litwin, Getz, and Gilbert. (Sybex)
' Copyright  1999 . All rights reserved.

' Database storing autonumber values
Const adhcAutoNumDb = "Ch02Auto.Mdb"

' Number of lock retry attempts
Const adhcLockRetries =  5 
' Lower bound of range of retry wait
Const adhcLockLBound = 2
' Upper bound of range of retry wait
Const adhcLockUBound =  10 

'Error constants
Const adhcErrRI = 3000
Const adhcLockErrCantUpdate2 = 3260
Const adhcLockErrTableInUse = 3262

Private Function adhCurrentDBPath() As String
    
    ' Return just the path of the current database,
    ' including the trailing backslash.
    
    ' From Access  2000  Developer's Handbook, Volume II
    ' by Litwin, Getz, and Gilbert (Sybex)
    ' Copyright 1999.  All rights reserved.
    
    ' NOTE: This is only useful if you're using DAO.
    ' If you're using ADO, use the CurrentProject.Path
    ' property instead.
    
    On Error GoTo HandleErrors
    
    Dim intPos As Integer
    Dim strFullPath As String
    
    strFullPath = CurrentDb.Name
    ' Find the last "\" in the file name.
    intPos = InStrRev(strFullPath, "\")
    
    ' Given the position of the final  "\" ,
    ' pull of the path portion.
    If intPos > 0 Then
        adhCurrentDBPath = Left$(strFullPath, intPos)
    Else
        adhCurrentDBPath = strFullPath
    End If
    
ExitHere:
    Exit Function
    
HandleErrors:
    Select Case Err.Number
        Case Else
            Err.Raise Err.Number, Err.Source, _
             Err.Description, _
             Err.HelpFile, Err.HelpContext
    End Select
    Resume ExitHere
End Function

Function adhAssignID(frm As Form, ByVal _
 strTableName As String, _
 ByVal strAutoNumField As String) As Variant

    ' Called from BeforeInsert event of a form to assign
    ' a new custom autonumber value for a field.
    ' Removes any record that cannot be saved.
    '
    ' From Access  2000  Developer's Handbook, Volume II
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
    '
    ' In:
    '    frm: form object variable that points to the
    '     currently opened form.
    '    strTableName: the name of the table for which
    '     the autonumber is to be retrieved.
    '    strAutoNumField: the name of the Long Integer
    '     field in strTableName that requires the new
    '     autonumber value.
    ' Out:
    '     Return value: None
    ' Example:
    '     varReturn = adhAssignID(Me,  "tblMenu" ,  "ID" )

    On Error GoTo adhAssignID_Err

    Dim lngNewID As Long

    lngNewID = adhGetNextAutoNumber(strTableName)
    Debug.Print lngNewID
    If lngNewID <> - 1  Then
        frm(strAutoNumField) = lngNewID
    Else
        MsgBox  "Can't Add Record; autonumber " & _
        "Not Available", vbOKOnly + vbCritical, _
        "Error Saving Record"
        frm.Undo
    End If

adhAssignID_Exit:
    Exit Function

adhAssignID_Err:
    frm.Undo
    MsgBox "Error " & Err.Number & ": " & Err.Description, _
     vbOKOnly + vbCritical, "adhAssignID"
    Resume adhAssignID_Exit

End Function

Function adhGetNextAutoNumber(ByVal strTableName _
 As String) As Long
    
    ' Returns the next custom autonumber value for a
    ' particular table. Autonumbers are stored in the
    ' database adhcAutoNumDb in tables with _ID appended
    ' for which they supply autonumbers.
    ' Returns -1  if a valid autonumber value cannot be
    ' retrieved due to locking problems.
    '
    ' From Access 2000 Developer's Handbook, Volume II
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright  1999 . All rights reserved.
    '
    ' In:
    '    strTableName: the name of the table for which the
    '     autonumber is to be retrieved.
    ' Out:
    '     Return value: A Long containing the new
    '      autonumber value, or -1 if the routine couldn't
    '      provide a autonumber value.
    ' Example:
    '     lngNewID = adhGetNextAutoNumber("tblMenu")

    On Error GoTo adhGetNextAutoNumber_Err

    Dim wrk As dao.Workspace
    Dim db As dao.Database
    Dim rstAutoNum As dao.Recordset
    Dim lngNextAutoNum As Long
    Dim lngW As Long
    Dim lngX As Long
    Dim intRetryCount As Integer
    
    Randomize
    DoCmd.Hourglass True
    intRetryCount = 0

    ' Open a recordset on the appropriate table in the
    ' autonumbers database denying all reads to others
    ' while it is open
    Set wrk = dao.DBEngine.Workspaces( 0 )
    Set db = wrk.OpenDatabase(adhCurrentDBPath() & _
     adhcAutoNumDb, False)
    Set rstAutoNum = db.OpenRecordset(strTableName _
     & "_ID ", dbOpenTable, dbDenyRead)

    ' Increment and return the autonumber value
    rstAutoNum.MoveFirst
    rstAutoNum.Edit
        lngNextAutoNum = rstAutoNum![NextAutoNumber]
        rstAutoNum![NextAutoNumber] = lngNextAutoNum + 1
    rstAutoNum.Update
 
    adhGetNextAutoNumber = lngNextAutoNum

adhGetNextAutoNumber_Exit:
    DoCmd.Hourglass False
    On Error Resume Next
    rstAutoNum.Close
    Set rstAutoNum = Nothing
    db.Close
    Set db = Nothing
    wrk.Close
    Set wrk = Nothing
    Exit Function

adhGetNextAutoNumber_Err:
    Select Case Err.Number
    Case adhcErrRI, _
     adhcLockErrCantUpdate2, _
     adhcLockErrTableInUse
        ' Table locked by another user
        intRetryCount = intRetryCount + 1 
        ' Tried too many times, give up
        If intRetryCount > adhcLockRetries Then
            adhGetNextAutoNumber = -1
            Resume adhGetNextAutoNumber_Exit
        Else
            ' Let Windows and the Jet Engine catch up
            dao.DBEngine.Idle
            ' Space out the retries based on a number
            ' that increases by the number of retries
            ' and a random number
            lngW = intRetryCount ^ 2 * _
             Int((adhcLockUBound - adhcLockLBound + 1) _
              * Rnd() + adhcLockLBound)
            ' Waste time, but let Windows
            ' multitask during this dead time.
            For lngW = 1 To lngW
                DoEvents
            Next lngW
            Resume
        End If
        Case Else
            ' Unexpected error
            MsgBox "Error  " & Err.Number & " :  " _
             & Err.Description, _
             vbOKOnly + vbCritical, " adhGetNextAutoNumber"
            adhGetNextAutoNumber = - 1 
            Resume adhGetNextAutoNumber_Exit
    End Select

End Function