... ich habe nach dem Code geschaut. Das Original habe ich leider nicht mehr gefunden, aber den von mir vor einigen Jahren angepassten Code:
Option Explicit
' # Globale Variablen und Konstanten
Const gsCodePos = "Lib.Tools-SequentialNumber."
'
' # Y = yearly | M = monthly | D = daily | N = never
Const csDefaultReset = "Y"
Const csDefaultMask = "YY-###.###"
' # Maskenname fürSetup-Dokument des Nummernkreises
Const csFormSetupSeqNumber = "Setup_SeqNumber"
' # Ansicht zum Initialisieren des Nummernkreis-Dokumentes => sortiert nach "KeyName"
Const csViewSeqNumber = "(#Setup)"
Dim sErrText As String
'
Private Function CheckSequentialNumber( sSetupKey As String , sNumber As String ) As Variant
' # Checks the last computed SequentialNumber - does the document exist?
' # Returns true or false
Dim sCodePos As String
sCodePos = gsCodePos + "CheckSequentialNumber."
sErrText = ""
'
' On Error Goto ErrorHandling
'
Dim session As New NotesSession
Dim dbThis As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Set dbThis = session.CurrentDatabase
Set view = dbThis.GetView( "($Setup)" ) ' view is required
If view Is Nothing Then
sErrText = " Das Setupdokument für den Nummernkreis konnte nicht initialisiert werden - "
sErrText = sErrText & "Die Ansicht '" & csViewSeqNumber & "' fehlt in der Datenbank"
CheckSequentialNumber = False
Goto wayout
Else
' # Search for document
Set doc = view.GetDocumentByKey( sNumber , True )
If Not doc Is Nothing Then
CheckSequentialNumber = True
sErrText = " Setup-Dokument gefunden - OK - " & sNumber
Else
sErrText = " Setup-Dokument für Nummernkreis konnte nicht gefunden werden - " & sNumber
CheckSequentialNumber = False
Goto wayout
End If
End If
wayout:
Print sCodePos & " Report:"
Print "..." + sErrText
Exit Function
ErrorHandling:
Print sCodePos & " Fehler-Report:"
Print Cstr( Err ) + " " + Error + " in Zeile: " & Cstr( Erl ) + sErrText
Exit Function
End Function
Private Function GetSetup_SequentialNumber( sSetupKey As String ) As NotesDocument
' # Initialize Setup-document - Das Setup-Dokument für den Nummernkreis initialisieren
' # Create new doc if not found - Wird keines gefunden, wird ein neues erstellt.
Dim sCodePos As String
'
sCodePos = gsCodePos + "GetSetup_SequentialNumber."
sErrText = ""
'
Dim session As New notesSession
Dim sName As String
Dim sLastName As String
Dim dbThis As NotesDatabase
Dim viewNumber As NotesView
Dim docSetup As NotesDocument
' On Error Goto ErrorHandling
Set GetSetup_SequentialNumber = Nothing
sName = session.CommonUserName
sLastName = strRight( sName , " " )
If Trim( sSetupKey ) <> "" Then
Set dbThis = session.CurrentDatabase
Set viewNumber = dbThis.GetView( "($Setup)" ) ' lookup view required
Set docSetup = viewNumber.GetDocumentByKey( sSetupKey , True )
If docSetup Is Nothing Then
Set docSetup = dbThis.CreateDocument
With docSetup
.Form = csFormSetupSeqNumber
.KeyName = sSetupKey
.SeqNumber = 0
.Reset = csDefaultReset ' => Declarations
.Mask = "YY-" & UCase( Left( sName , 1 ) ) & UCase( Left( sLastName , 2 ) ) & "-###.###" ' csDefaultMask ' => Declarations
.Year = Cint( Year(Today()) )
.Month = Cint( Month(Today()) )
.Day = Cint( Day(Today()) )
Call docSetup.Save( True , True )
End With
End If
Set GetSetup_SequentialNumber = docSetup
Else
sErrText = "Kein Schlüssel für Setup des Nummernkreises."
Goto ErrorHandling
End If
Exit Function
GoTo wayOut
ErrorHandling:
Print sCodePos & " Error-no " & Cstr( Err ) + " in row " & erl & ": " & Error & & " => " & sErrText
Resume Next
WayOut:
End Function
Private Function MaskSequentialNumber( newnum As Integer, mask As String, sYear As String, sMonth As String, sDay As String ) As String
' Returns the masksed (formatted) sequential number string
Dim sNewnumString As String
Dim sMaskedNewNum As String
Dim sChar As String
Dim nLen As Integer
Dim nPos As Integer
Dim yPos As Integer
Dim mPos As Integer
Dim dPos As Integer
Dim c As Integer
' On Error Goto errorHandling
sNewnumString = Cstr( newnum )
sMaskedNewNum = "" ' the formatted seq. num. string
nLen = Len(Cstr(newnum))
nPos = 0
yPos = 0
mPos = 0
dPos = 0
For c = Len(mask) To 1 Step -1 ' read backwards
sChar = Mid$( mask, c, 1 )
Select Case sChar ' # Ucase(mChar )
Case "#" :
nPos = nPos + 1
If nPos > nLen Then
sMaskedNewNum = "0" & sMaskedNewNum
Else
sMaskedNewNum = Mid( sNewnumString, (nLen - (nPos - 1)), 1) & sMaskedNewNum
End If
Case "Y" :
yPos = yPos + 1
If yPos < 5 Then sMaskedNewNum = Mid( sYear, 5 - yPos, 1) & sMaskedNewNum
Case "M" :
mPos = mPos + 1
If mPos < 3 Then sMaskedNewNum = Mid( sMonth, 3 - mPos, 1) & sMaskedNewNum
Case "D" :
dPos = dPos + 1
If dPos < 3 Then sMaskedNewNum = Mid( sDay, 3 - dPos, 1) & sMaskedNewNum
Case Else
sMaskedNewNum = sChar & sMaskedNewNum
End Select
Next ' character in mask
' return masked number
MaskSequentialNumber = sMaskedNewNum$
' Exit Function
GoTo wayOut
errorHandling:
Print "SequentialNumber.MaskSequentialNumber reports error-no" & Cstr(Err) & " in row " & erl & ": " & Error
Resume Next
wayOut:
End Function
Function GetSequentialNumber( sSetupKey As String , bLookup As Variant ) As String
' # Ermittelt die nächste Nummer im Nummernkreis sSetupKey.
' # die Anschlußprüfung ist derzeit deaktiviert
bLookup = False
%REM
sNumber = GetSequentialNumber( "Anton Tauscher.Person" , True )
' # Pers. Setup-Dokument für Nummernkreis "Person" mit Anschlußprüfung der Nummer
sNumber = GetSequentialNumber( "Anton Tauscher.MainTask" , False )
' # Pers. Setup-Dokument für Nummernkreis "MainTask" ohne Anschlußprüfung der Nummer
%END REM
'
Print "GetSequentialNumber => " & sSetupKey
Dim sCodePos As String
sCodePos = gsCodePos + "GetSequentialNumber."
sErrText = ""
'
Dim session As New NotesSession
Dim doc As NotesDocument
Dim bSaved As Integer ' acts as semaphor
Dim tries As Integer
Dim delay As Long ' record locking
Dim num As Integer
Dim newnum As Integer ' current and next number
Dim currentYear As Integer
Dim currentMonth As Integer
Dim currentDay As Integer ' today in numbers
Dim sYear As String
Dim sMonth As String
Dim sDay As String ' today in text
Dim proNum As Integer
Dim proYear As Integer
Dim proMonth As Integer
Dim proDay As Integer ' last vals (in profileNumber)
Dim sMask As String
Dim sResetNum As String ' formatting (in profileNumber)
Dim sMaskedNewNum As String ' the final result
Dim sMaskedOldNum As String ' the last result
Dim bChecked As Variant
Dim nServer As New NotesName( session.CurrentDatabase.Server )
Dim sServer As String
sServer = nServer.Abbreviated
If sServer = "" Then sServer = "[Local]" ' Server darf nicht leer sein
' On Error Goto errorHandling
bSaved = False
currentYear = Year( Today )
currentMonth = Month( Today )
currentDay = Day( Today )
tries = 1
' Loop while document profileNumber is not saved
' If another user has the document open then it can not be saved.
' Aborts after 10 tries and returns 0000 as number
While bSaved = False
Set doc = GetSetup_SequentialNumber( sSetupKey )
' # Kein Setup-Dokument für diesen Nummernkreis vorhanden
If doc Is Nothing Then
Print sErrText + " Kein Setup-Dokument für diesen Nummernkreis gefunden: " & sSetupKey
Goto ErrorHandling
End If
'
If doc.mask(0) = "DISABLED" Then ' # out of order
GetSequentialNumber = ""
Exit Function
End If
' # Initialisieren der Setup-Parameter
If Not IsNumeric( doc.SeqNumber(0) ) Then
Print sErrText + " Es kann keine Zahl eingelesen werden: " & sSetupKey & " => '" & Cstr(doc.SeqNumber(0)) & "'"
Goto ErrorHandling
Else
Print "... letzte vergebene Nummer für " & sSetupKey & " => '" & doc.SeqNumber(0) & "'"
End If
'
proNum = CInt( doc.SeqNumber(0) )
num = proNum
proYear = CInt( doc.Year(0) )
proMonth = CInt( doc.Month(0) )
proDay = CInt( doc.Day(0) )
sMask = doc.Mask( 0 )
sResetNum = doc.Reset( 0 )
' # jährlich
If proYear <> currentYear Then doc.year = currentYear
sYear = Cstr( currentYear )
' # monatlich
If proMonth <> currentMonth Then doc.month = currentMonth
If currentMonth < 10 Then sMonth = "0" & Cstr(currentMonth) Else sMonth = Cstr(currentMonth)
' # täglich
If proDay <> currentDay Then doc.day = currentDay
If currentDay < 10 Then sDay = "0" & Cstr( currentDay ) Else sDay = Cstr( currentDay )
' # Zurücksetzen
Select Case sResetNum
Case "N" : num = proNum ' niemals
Case "Y" : If proYear = currentYear Then num = proNum Else num = 0 ' jährlich
Case "M" : If proMonth = currentMonth Then num = proNum Else num = 0 ' monatlich
Case "D" : If proDay = currentDay Then num = proNum Else num = 0 ' täglich
End Select
newnum = num + 1 ' # neue Nummer berechnen
' # Maskierung und Formatierung der neuen Nummer
sMaskedNewNum = MaskSequentialNumber( newnum, sMask, sYear, sMonth, sDay )
If bLookup Then
sMaskedOldNum = MaskSequentialNumber( num, sMask, sYear, sMonth, sDay )
bChecked = CheckSequentialNumber( sSetupKey , sMaskedOldNum )
If num = 0 Then bChecked = True
End If
' # Die aktuelle Nummer hinterlegen
If bLookup Then
If bChecked Then
doc.SeqNumber = newnum
Else
' # auf die letzte Nummer zurückgreifen
While bChecked = False
num = num - 1
sMaskedOldNum = MaskSequentialNumber( num, sMask, sYear, sMonth, sDay )
sErrText = " Check für: " + sMaskedOldNum
bChecked = CheckSequentialNumber( sSetupKey , sMaskedOldNum )
If num = 0 Then bChecked = True
Wend
sMaskedNewNum = MaskSequentialNumber( num + 1 , sMask, sYear, sMonth, sDay )
doc.SeqNumber = num + 1
End If
Else
doc.SeqNumber = newnum
End If
' # Speichern des Setup-Dokumentes
bSaved = doc.save( False, False )
If bSaved = False Then
Set doc = Nothing ' release to prevent deadlock
tries = tries + 1
If tries > 20 Then
' timeout feststellen nach 20 Läufen
sErrText = " TimeOut"
Goto ErrorHandling
Else
For delay = 1 To 10000
' warten
' 20 x mal versuchen...
Next
End If
Else
' Print "... Fortlaufende Nummer: " & sMaskedNewNum
End If
Wend ' while bSaved = false
'
GetSequentialNumber = sMaskedNewNum
'
'Exit Function
GoTo wayOut
'
errorHandling:
'
Print sCodePos & " error-no" & err & " in row: " & Erl & ": " error & " => " sErrText
GetSequentialNumber = "0000"
Resume wayOut
wayOut:
End Function
... ich hoffe es hilft dir weiter. Schau dir den Code an. Es wird mit Lookup-ansichten gearbeitet, die dann natürlich entsprechend erstellt werden müssen...
Thema: Primärschlüssel: JJJJ-XXXX bzw. Jahr-ID, durchlaufende Nummerierung, Zählwerk (Gelesen 6705 mal)