Option Explicit
Sub Workbook_BeforePrint(Cancel As Boolean)
Const cRANGE_DATUM = M1
Const cFORMAT_DATUM = d. mmmm yyyy
Const cRANGE_MIETVERTRAGNT = I5
Dim s As String
Dim Zelle As Range
Set Zelle = ActiveSheet.Range(cRANGE_DATUM)
If Not DatumPruefen(Zelle, cFORMAT_DATUM) Then
Cancel = True
GoTo AUFRAEUMEN
End If
Zelle = ActiveSheet.Range(cRANGE_MIETVERTRAGNT)
If Zelle.Value = Then
s = InputBox(Mietvertrag Nt. eintragen! ! !)
If s = Then Cancel = True: GoTo AUFRAEUMEN
Zelle = s
End If
AUFRAEUMEN:
Set Zelle = Nothing
End Sub
Private Function DatumPruefen(Zelle As Range, sFormat As String) As Boolean
Dim s As String, sZusatz As String, sEingabe As String
Dim sTag As String, sMonat As String, sJahr As String
Dim lTag As Long, lMonat As Long, lJahr As Long, pos As Long
Dim ddate As Date
If IsDate(Zelle.Value) Then
DatumPruefen = True
Exit Function
End If
Do
NOCHMAL:
s = InputBox( _
Bitte Datum eingeben: & vbLf & (t.m oder t.m.yy oder t.m.yyyy) & _
vbLf & vbLf & sZusatz, _
Eingabe Datum, _
s)
If s = Then Exit Function->Abbruch
sEingabe = s: sTag = : sMonat = : sJahr =
->*** Tag ***
pos = InStr(1, sEingabe, .)
If pos < 1 Then sZusatz = Angabe Tag ungültig.: GoTo NOCHMAL
sTag = Left(sEingabe, pos - 1)
sEingabe = Right(sEingabe, Len(sEingabe) - pos)->Tag aus Eingabe abschneiden
On Error Resume Next
lTag = sTag
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
sZusatz = Angabe Tag ungültig.: GoTo NOCHMAL
End If
On Error GoTo 0
->*** Monat ***
pos = InStr(1, sEingabe, .)
If pos < 1 Then
sMonat = sEingabe
sEingabe =
Else
sMonat = Left(sEingabe, pos - 1)
sEingabe = Right(sEingabe, Len(sEingabe) - pos)
End If
On Error Resume Next
lMonat = sMonat
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
sZusatz = Angabe Monat ungültig.: GoTo NOCHMAL
End If
On Error GoTo 0
->*** Jahr ***
sJahr = sEingabe
If Len(sJahr) = 0 Then sJahr = Format(Now(), yyyy)
On Error Resume Next
lJahr = sJahr
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
sZusatz = Angabe Jahr ungültig.: GoTo NOCHMAL
End If
On Error GoTo 0
If lJahr < 100 Then lJahr = lJahr + 2000
->*** Wertebereiche prüfen
On Error Resume Next
ddate = lTag & . & lMonat & . & lJahr
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
sZusatz = Datum ungültig.: GoTo NOCHMAL
End If
On Error GoTo 0
If (Day(ddate) <> lTag) Or _
(Month(ddate) <> lMonat) Or _
(lJahr > 2039) Then
sZusatz = Datum ungültig.: GoTo NOCHMAL
End If
->*** Zelle formatieren und Datum eintragen
Zelle.NumberFormat = sFormat
Zelle.Value = ddate
Exit Do
Loop
DatumPruefen = False
End Function