'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr




Public Function date_str(s As Variant, Optional o_f = "d2.m2.y4!", Optional i_f = "dmy") As String
  date_str = ""
  d = "00": m = "00": y = "0000"
  b = 1
  Dim mon(2) As String
  'ich wollt halt mal was ausprobieren
  'wer's nicht mag kann ja Arrays benutzen :-)
  mon(0) = "   JanFebMarAprMaiJunJulAugSepOktNovDez"
  mon(1) = "JanuarFebruarMärzAprilMaiJuniJuliAugustSeptemberOktoberNovemberDezember"
  mon(2) = "1     2      3   4    5  6   7   8     9        10     11      12      13"
  
  If IsNull(o_f) Then o_f = "d2.m2.y4!"

  'neu eingefügt da sonst ein Fehler bei
  '4stelligen echten Jahreszahlen >1900 auftrat
  
  'wieder entfernt, da nur ein Problem durch ein anderes ersetzt wurde!
  'If IsDate(s) Then s = Day(s) & "." & Month(s) & "." & Year(s)
  
  'erwarte das Datum in der Reihenfolge i_f also z.B. "dmy"
  'Standard= "dmy"
  
  For i = 1 To Len(s)
    s_chr = Mid(s, i, 1)
    Select Case s_chr
    Case "0" To "9": Select Case Mid(i_f, b, 1)
                       Case "d": d = Right(d & s_chr, 2)
                       Case "m": m = Right(m & s_chr, 2)
                       Case "y": y = Right(y & s_chr, 4)
                       Case Else:
                     End Select
    Case Else: b = b + 1
    End Select
  Next i
  
  'gib das Datum im Format o_f aus (siehe unten)
  'Standard= "d2.m2.y4!"
  
  For i = 0 To 2
    Select Case Mid(o_f, 1 + i * 3, 1)
       Case "d":
         tr = Mid(o_f, 3 + i * 3, 1)
         If tr = "!" Then tr = ""
         Select Case Mid(o_f, 2 + i * 3, 1)
           Case "1": If Left(d, 1) = "0" Then d = Right(d, 1)
                     d = d & tr
           Case "2": d = d & tr
           Case Else: d = ""
         End Select
         date_str = date_str & d
       Case "m":
         tr = Mid(o_f, 3 + i * 3, 1)
         If tr = "!" Then tr = ""
         Select Case Mid(o_f, 2 + i * 3, 1)
           Case "1": If Left(m, 1) = "0" Then m = Right(m, 1)
                     m = m & tr
           Case "2": m = m & tr
           Case "3": m = Mid(mon(0), CInt(m) * 3 + 1, 3) & tr
           Case "4": anfang = CInt(m)
                     von = CLng(InStr(1, mon(2), CStr(anfang)))
                     bis = CLng(InStr(1, mon(2), CStr(anfang + 1)))
                     m = Mid(mon(1), von, bis - von) & tr
           Case Else: m = ""
         End Select
         date_str = date_str & m
       Case "y":
         tr = Mid(o_f, 3 + i * 3, 1)
         If tr = "!" Then tr = ""
         Select Case Mid(o_f, 2 + i * 3, 1)
           Case "2": y = Right(y, 2) & tr
           Case "4": y = y & tr
           Case Else: y = ""
         End Select
         date_str = date_str & y
       Case Else:
    End Select
  Next i
  
  'Format von o_f--> 3*{<b><n><z>} -->
  '<b> = "d" "m" "y"
  '<n> = "0" "1" "2" für d und
  '      "0" "1" "2" "3" "4" für m bzw.
  '        wobei gilt m=3 --> Jan Feb Mar ...
  '                   m=4 --> Januar Februar März ...
  '      "0" "2" "4" für y
  '<z> = "!" --> trennzeichen=""
  '<z> = "." " " "-" etc. als trennzeichen
  'z.B. m1*y2!d0! gibt für 13.1.1807 = 1*07
  'Standard "d2.m2.y4!"
  
  'Format i_f ---> "dmy" "y" "my" "ymd" etc.
  
End Function





Public Function date_diff(d1 As Variant, d2 As Variant) As Variant
'd1 muß ein Datum oder ein Datumstring sein,
'd2 kann ein Datum oder eine Zahl Singel,Long,Double sein
On Error GoTo abbruch
fehler = "#Wert"

'Tagesdifferenz d1-d2
  td1 = VarType(d1)
  td2 = VarType(d2)
     Select Case td2
       Case 7: 'datum
            Select Case td1
               Case 7, 8: 'datum,string
                 differenz = (td1 - td2)
                 date_diff = CLng(CDate(d1) - CDate(d2) - differenz)
               Case Else:
                   date_diff = fehler
            End Select
       Case 8: 'string
            Select Case td1
               Case 7, 8: 'datum,string
                 differenz = (td1 - td2)
                 date_diff = CLng(CDate(d1) - CDate(d2) - differenz)
               Case Else:
                   date_diff = fehler
            End Select
       Case 3, 4, 5: 'single,long,double
       'berechne neues Datum und zeige es an
       'dieser Teil ist noch fehlerhaft bei
       'Ergebnis zw. 30.12.1899 und 1.1.1900
            Select Case td1
               Case 7: 'datum
                   date_diff = CDate(d1 - d2)
                   If date_diff < 1 Then date_diff = date_diff + 1
               Case 8: 'string
                   date_diff = CDate(CDate(d1) - d2)
                   If date_diff > 0 Then date_diff = date_diff - 1
               Case Else:
                   date_diff = fehler
            End Select
            If date_diff <= 0 Then date_diff = CStr(date_diff)
       Case Else: 'falsche Wertzuweisung
          date_diff = fehler
      End Select
abbruch:
End Function




'alternative Funktion
'von Frank Arendt-Theilen
Function fDATUMDIFF(Anfangsdatum, Enddatum) As Long
Dim intDifferenz As Integer
  intDifferenz = VarType(Enddatum) - VarType(Anfangsdatum)
  fDATUMDIFF = CDate(Enddatum) - CDate(Anfangsdatum) - intDifferenz
End Function