Hi all!
I am trying to implement the generate autonumber function from faq700-184 and I have some problems.
First, is this possible to do in ADO?
If not how do I set my database to another database then the current database (CurrentDB())?
I have tried with:
Dim dbm As DAO.Database
Set dbm = “C:\Database\database1.mdb”
And I get the following debug error: “Type mismatch”
Any and all help is appreciated, Larsson
Here is the function:
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
I am trying to implement the generate autonumber function from faq700-184 and I have some problems.
First, is this possible to do in ADO?
If not how do I set my database to another database then the current database (CurrentDB())?
I have tried with:
Dim dbm As DAO.Database
Set dbm = “C:\Database\database1.mdb”
And I get the following debug error: “Type mismatch”
Any and all help is appreciated, Larsson
Here is the function:
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