Domino 9 und frühere Versionen > ND8: Entwicklung

Primärschlüssel: JJJJ-XXXX bzw. Jahr-ID, durchlaufende Nummerierung, Zählwerk

<< < (4/4)

ata:
... ich habe nach dem Code geschaut. Das Original habe ich leider nicht mehr gefunden, aber den von mir vor einigen Jahren angepassten Code:


--- 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

--- Ende Code ---


... 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...

Toni  ;)

Navigation

[0] Themen-Index

[*] Vorherige Sete