TKSoft-Online

Public Function UniCounter_New(intNoLen As Integer, strTabName As String, _
                            strFeldName As String, intType As Integer, _
                            boolStart As Boolean, boolAlign As Boolean, _
                            Optional strArg As String = "-", _
                            Optional strArg2 As String = "", _
                            Optional sPrefix As String = "", Optional dtStart As Date) As String
'*******************************************
'Name:      Unicounter_New (Function)
'Purpose:   Erstellt einen benutzerdefinierten Tageszähler
'Author:    Tommyk
'Date:      December 28, 2005, 04:03:35
'Inputs:    intNoLen=Anzahl der Zählerstellen,
'           strTabName= Name der Tabelle des Zählers,
'           strFeldName=Name des Zählfeldes,
'           boolStart= Beginn des Zählers (True bei 1, False bei 0),
'           boolAlign=Ausrichtung des Zählers (True Zähler Rechts,
'                                              False Zähler Links),
'           strArg=Trennzeichen Standard "-"
'           strArg2=Datumstrennzeichen Standard ""
'           intType= DatumsTyp, 1=Tage (yymmdd), 2=Tage (ddmmyyyy),
'                    3=Tage (ddmmyyyy formatiert), 4=Woche (wwyyyy formatiert)
'           5=Monat (mmyyyy formatiert), 6=Jahr (yyyy), 7=Woche (yyww formatiert), 8=Woche (yyyyww formatiert)
'Output:    benutzerdefinierten Zähler
'Example:   Standardwert des Zählfeldes im Form:
'      z.B. UniCounter_New(3;"tbl_Test";"Zaehler_ID";Tage_Formatiert;True;True;"-";".";"ER")
'*******************************************
On Error GoTo ErrHandler
    Dim strBedingung As String
    Dim strNo As String, strDate As String
    Dim strMax, intLenStr As Integer
    Dim strAlignment As String
    Dim intLenPrefix As Integer
    Dim dtTemp As Date
 
    If dtStart = 0 Then
        dtTemp = Date
    Else
        dtTemp = dtStart
    End If
 
    ' Ermitteln des Datumformates
    Select Case intType
      Case Is = 1     'Tageszähler1
        strDate = Format(dtTemp, "yymmdd")
      Case Is = 2     'Tageszähler2
        strDate = Format(dtTemp, "ddmmyyyy")
      Case Is = 3     'Tageszähler3
        strDate = Format(dtTemp, "dd") & strArg2 & Format(dtTemp, "mm") & _
                  strArg2 & Year(dtTemp)
      Case Is = 4     ' Wochenzähler
        strDate = Format(dtTemp, "ww") & strArg2 & Year(dtTemp)
      Case Is = 5     ' Monatszähler
        strDate = Format(dtTemp, "mm") & strArg2 & Year(dtTemp)
      Case Is = 6     ' Jahreszähler
        strDate = Format(dtTemp, "yyyy")
      Case Is = 7     ' Wochenzähler2
        strDate = Format(dtTemp, "yy") & strArg2 & Format(dtTemp, "ww")
      Case Is = 8     ' Wochenzähler3
        strDate = Format(dtTemp, "yyyy") & strArg2 & Format(dtTemp, "ww")
      Case Is = 9     ' Jahreszähler2
        strDate = Format(dtTemp, "yy")
      Case Else
        GoTo ExitHere
    End Select
    'Prüfen auf Präfix
    If sPrefix <> "" Then intLenPrefix = Len(sPrefix) + 1
    ' Länge des Datumstrings
    intLenStr = Len(strDate)
    ' Festlegen ob Zähler Rechts oder Links
    If boolAlign = True Then
        If sPrefix = "" Then
            strAlignment = "LEFT"
            strBedingung = strAlignment & "([" & strFeldName & "]," & _
                           intLenStr & ")='" & strDate & "'"
          Else
            strAlignment = "MID"
            strBedingung = strAlignment & "([" & strFeldName & "]," & _
                           intLenPrefix & "," & intLenStr & ")='" & _
                           strDate & "'"
        End If
      Else
        strAlignment = "RIGHT"
        strBedingung = strAlignment & "([" & strFeldName & "]," & _
                       intLenStr & ")='" & strDate & "'"
    End If
    ' Letzen Wert suchen
    strMax = DMax(strFeldName, strTabName, strBedingung)
    If IsNull(strMax) Then
        ' Start mit 0 oder 1
        If boolStart = False Then
            strNo = String$(intNoLen, "0")
          Else
            strNo = String$(intNoLen - 1, "0") & "1"
        End If
      Else
        ' Zähler Links oder Rechts
        If boolAlign = True Then
            strNo = Right(strMax, intNoLen)
          Else
            If intLenPrefix = 0 Then
                strNo = Left(strMax, intNoLen)
            Else
                strNo = Mid(strMax, intLenPrefix, intNoLen)
            End If
        End If
        ' Zähler setzen
        strNo = Format$(Val(strNo) + 1, String$(intNoLen, "0"))
    End If
    ' Zählerstring zusammensetzen
    If intLenPrefix = 0 Then
        If boolAlign = True Then
            UniCounter_New = strDate & strArg & strNo
          Else
            UniCounter_New = strNo & strArg & strDate
        End If
      Else
        If boolAlign = True Then
            UniCounter_New = sPrefix & strDate & strArg & strNo
          Else
            UniCounter_New = sPrefix & strNo & strArg & Format(Month(Date), "00") & strDate
        End If
    End If
ExitHere:
    Exit Function
ErrHandler:
    Dim strErrString As String
    strErrString = "Error Information..." & vbCrLf
    strErrString = strErrString & "Error#: " & Err.Number & vbCrLf
    strErrString = strErrString & "Description: " & Err.Description
    MsgBox strErrString, vbCritical + vbOKOnly, "Function: Unicounter_New"
    Resume ExitHere
End Function

UniCounter_New(3;"tblRechnung";"RechnungNr";9;Wahr;Falsch;"-";"";"ER-")