VB help

[philjayj]

Hi

Attached is a piece of VB code being used in an Access DB. Its main function is to generate a number, comprising of a date and a 6-digit number (eg. 20080226-078626). The problem I'm having is that the 6-digits after the date are not unique and its essential they are. Also, none of the 6-digit numbers after the date begin with 0. Although the 6 digits should be completely random, none of them begin with zero, which is limiting the range of the numbers.

Any help would be greatly appreciated, but I am a complete novice at programming, so if you could keep it simple, that would be great.

Many thanks

Option Compare Database
Option Explicit

Function CreateCustRef(Optional intLength As Integer = 6, Optional blnNonZeroStart As Boolean = True) As String

Dim strPN As String
Dim i As Integer

Randomize

If blnNonZeroStart Then
strPN = Int(Rnd * 9) + 1
i = 2
Else
i = 1
End If

Do While i <= intLength
strPN = strPN & Int(Rnd * 9)
i = i + 1
Loop

CreateCustRef = Format(Date, "yyyymmdd") & "-" & strPN
End Function

Public Function GetNewCustRef(Optional lngUniqueCRN As Long = 0, Optional strPrefix As String = "") As String
Dim strPN As String
On Error GoTo ErrorHandler

Do
'Get new (hopefully) Customer Number
strPN = strPrefix & CreateCustRef(6 - Len(strPrefix), (Len(strPrefix) = 0))

'It might be random and therefore it is not unique. Check it!
With CurrentDb.OpenRecordset(" SELECT * FROM Table1 WHERE CustRef = '" & strPN & "'")
'Bail out if no duplication found (strPN is unique).
If .RecordCount = 0 Then Exit Do
.Close
End With
Loop

'Return value is unique, non-empty and therefore True.
GetNewCustRef = strPN

ExitProcedure:
Exit Function
ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description
'Set return value to empty string.
GetNewCustRef = ""

Resume ExitProcedure
End Function

'Run this sub-routine when you have added the PatientNumber field to the table 'Table1' <- change this below if necessary.
'Change '40' to your desired prefix, or omit it if you do not have a prefix
Public Sub FillEmptyCustRefs()
DoCmd.RunSQL "UPDATE Table1 SET CustRef = GetNewCustRef (UniqueCRN) WHERE (CustRef Is Null) OR (CustRef = '')"
End Sub