Dim Tag As Long
Dim Monat As Long
Dim Jahr As Long
Dim I As Long
Dim sMonat As String
Dim sDatum As String

If Err.Number <> 0 Then
    MsgBox "Irgendwas stimmt leider nicht. Kümmere mich später drum. Sorry!", vbCritical, "Toni"
    End
End If

'Ist wirklich ein IDW offen?
If ThisApplication.ActiveDocumentType = kDrawingDocumentObject Then

'Pfad von iProps
Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")

'Datum von System erhalten und in gewünschtes Format 1. April 2007
Datum = Mid(Date, 1, 10)

'Tag:
I = InStr(Datum, ".")
If I Then
    Tag = Val(Left$(Datum, I - 1))
    Datum = Mid$(Datum, I + 1)
Else
    Tag = Val(Left$(Datum, 2))
    Datum = Mid$(Datum, 3)
End If
If Tag = 0 Then MsgBox "Tag = 0! Aber wieso??", vbCritical, "Toni"

'Monat
If I Then
    Monat = Val(Left$(Datum, I - 1))
    Datum = Mid$(Datum, I + 1)
Else
    Monat = Val(Left$(Datum, 2))
    Datum = Mid$(Datum, 3)
End If
'Monat in Wort umschreiben
If Monat = 0 Then
    Monat = Month(Now) 'Aktuellen Monat berücksichtigen
    If Tag < Day(Now) Then Monat = Monat + 1
End If
If Monat = 1 Then
    sMonat = "Januar"
    ElseIf Monat = 2 Then
    sMonat = "Februar"
    ElseIf Monat = 3 Then
    sMonat = "März"
    ElseIf Monat = 4 Then
    sMonat = "April"
    ElseIf Monat = 5 Then
    sMonat = "Mai"
    ElseIf Monat = 6 Then
    sMonat = "Juni"
    ElseIf Monat = 7 Then
    sMonat = "Juli"
    ElseIf Monat = 8 Then
    sMonat = "August"
    ElseIf Monat = 9 Then
    sMonat = "September"
    ElseIf Monat = 10 Then
    sMonat = "Oktober"
    ElseIf Monat = 11 Then
    sMonat = "November"
    ElseIf Monat = 12 Then
    sMonat = "Dezember"
    ElseIf Monat = 0 Then MsgBox "Monat = 0! Aber wieso??", vbCritical, "Toni"
End If

'Jahr
Jahr = Val(Datum)
If Jahr = 0 Then 'Aktuelles Jahr berücksichtigen
    Jahr = Year(Now)
    If DateSerial(Jahr, Monat, Tag) < Now Then Jahr = Jahr + 1
        ElseIf Jahr < 100 Then 'Aktuelles Jahrhundert berücksichtigen
        Jahr = Year(Now)
    End If