A
Arvin Meyer [MVP]
I just got an email from someone concerning a bug in code I posted in this
forum last November under the subject of "Help with auto numbers in Access"
I found another bug in addition so I wanted to correct the code and since I
can't post to that thread any longer, I've duplicated the subject, in the
hope that Google will pop up the latest one first. The code creates an
autonumber based on the date in the format: 06-0001 ... 99-9999
If you have a requirement for more than 10,000 or to last longer than the
year 2099, make alterations to allow for those contingencies:
Function DateNum() As String
'********************************************************************
' Name: DateNum
' Purpose: Generate an incremental "number" based on the year
'
' Author: Arvin Meyer
' Date: July 27, 2003, Revised February/25/2006
' Comment: Assumes Table1 As Table and CaseNum As Field
' Generates in the format of 03-0001, 03-0002, etc.
' Seed the first number if other than 0000
'********************************************************************
On Error GoTo Error_Handler
Dim intNumber As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Select [CaseNum] from [Table1] order by
[CaseNum];")
If Not rs.EOF Then
rs.MoveLast
If Left(rs.Fields("CaseNum"), 2) = CStr(Right(year(Date), 2)) Then
intNumber = Val(Mid(rs.Fields("CaseNum"), 4)) + 1
Else
intNumber = 1
End If
End If
DateNum = Right(year(Date), 2) & "-" & Format(intNumber, "0000")
With rs
.AddNew
!CaseNum = DateNum
.Update
End With
Exit_Here:
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function
Error_Handler: 'If someone is editing this record trap the error
Dim intRetry As Integer
If Err = 3188 Then
intRetry = intRetry + 1
If intRetry < 100 Then
Resume
Else 'Time out retries
MsgBox Err.Number, vbOKOnly, "Another user editing this number"
Resume Exit_Here
End If
Else 'Handle other errors
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "Problem
Generating Number"
Resume Exit_Here
End If
End Function
--
Arvin Meyer, MCP, MVP
Microsoft Access
Free Access downloads
http://www.datastrat.com
http://www.mvps.org/access
forum last November under the subject of "Help with auto numbers in Access"
I found another bug in addition so I wanted to correct the code and since I
can't post to that thread any longer, I've duplicated the subject, in the
hope that Google will pop up the latest one first. The code creates an
autonumber based on the date in the format: 06-0001 ... 99-9999
If you have a requirement for more than 10,000 or to last longer than the
year 2099, make alterations to allow for those contingencies:
Function DateNum() As String
'********************************************************************
' Name: DateNum
' Purpose: Generate an incremental "number" based on the year
'
' Author: Arvin Meyer
' Date: July 27, 2003, Revised February/25/2006
' Comment: Assumes Table1 As Table and CaseNum As Field
' Generates in the format of 03-0001, 03-0002, etc.
' Seed the first number if other than 0000
'********************************************************************
On Error GoTo Error_Handler
Dim intNumber As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Select [CaseNum] from [Table1] order by
[CaseNum];")
If Not rs.EOF Then
rs.MoveLast
If Left(rs.Fields("CaseNum"), 2) = CStr(Right(year(Date), 2)) Then
intNumber = Val(Mid(rs.Fields("CaseNum"), 4)) + 1
Else
intNumber = 1
End If
End If
DateNum = Right(year(Date), 2) & "-" & Format(intNumber, "0000")
With rs
.AddNew
!CaseNum = DateNum
.Update
End With
Exit_Here:
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function
Error_Handler: 'If someone is editing this record trap the error
Dim intRetry As Integer
If Err = 3188 Then
intRetry = intRetry + 1
If intRetry < 100 Then
Resume
Else 'Time out retries
MsgBox Err.Number, vbOKOnly, "Another user editing this number"
Resume Exit_Here
End If
Else 'Handle other errors
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "Problem
Generating Number"
Resume Exit_Here
End If
End Function
--
Arvin Meyer, MCP, MVP
Microsoft Access
Free Access downloads
http://www.datastrat.com
http://www.mvps.org/access