Option Explicit
Private WithEvents MyWord As Word.Application
Private Sub Document_New()
Set MyWord = Application
End Sub
Private Sub Document_Open()
Set MyWord = Application
End Sub
Private Sub MyWord_DocumentBeforeSave(ByVal doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
Dim sFilename As String, sFilenameNeu As String
Dim pos As Long
If Not SaveAsUI Then
pos = InStr(1, .dot, doc.Name)
->keine Dokumentenvorlage ?
If pos = 0 Then
->Wenn _Save, dann Namen prüfen
sFilename = doc.Name
Call Dateinamen_Datum_Anhaengen_Ersetzen(sFilename, sFilenameNeu)
->mit neuem Namen speichern
Application.DisplayAlerts = wdAlertsNone
doc.SaveAs FileName:=doc.Path & Application.PathSeparator & sFilenameNeu
Application.DisplayAlerts = wdAlertsAll
End If
End If
End Sub
'*************************************************************************
Private Function Dateinamen_Datum_Anhaengen_Ersetzen(sDNameAlt As String, _
sDNameNeu As String)
Dim sDate As String, sDatum As String, dDate As String
Dim sEndung As String, sDName As String
Dim pos As Long, posLast As Long
sDName = sDNameAlt
->Endung abschneiden
pos = InStr(1, sDName, .)
If pos > 0 Then
Do
posLast = pos
pos = InStr(posLast + 1, sDName, .)
If pos = 0 Then Exit Do
Loop
sEndung = Right(sDName, Len(sDName) - (posLast - 1))
sDName = Left(sDName, posLast - 1)
Else
sEndung =
sDName = sDName
End If
->pruefen, ob DNameAlt bereits ein Datum mit entsprechendem Format enthält
->nein: Datum _yyyymmdd anfuegen, ja : Datum _yyyymmdd ersetzen, wenn ungleich
sDate = Format(Now(), _yyyymmdd)
If Len(sDName) > (Len(sDate)) Then
If Right(sDName, Len(sDate)) <> sDate Then
If IstEinDatum(Right(sDName, Len(sDate))) Then
->ja : Datum _yyyymmdd ersetzen
sDNameNeu = Left(sDName, Len(sDName) - Len(sDate)) & sDate & sEndung
Else
->nein: Datum _yyyymmdd anfuegen
sDNameNeu = sDName & sDate & sEndung
End If
Else
->Datum gleich, bleibt so
sDNameNeu = sDName & sEndung
End If
Else
->nein: Datum _yyyymmdd anfuegen
sDNameNeu = sDName & sDate & sEndung
End If
End Function
'*************************************************************************
Private Function IstEinDatum(sDatum As String) As Boolean
Dim sStr As String, lLong As Long
->Datum muß _yyyymmdd entsprechen
IstEinDatum = False
->_ prüfen
If Mid(sDatum, 1, 1) <> _ Then GoTo AUFRAEUMEN
On Error Resume Next
->Jahr prüfen
sStr = Mid(sDatum, 2, 4)
lLong = sStr
If Err.Number <> 0 Then GoTo AUFRAEUMEN
If Not (2007 <= lLong And lLong <= 2039) Then GoTo AUFRAEUMEN
->Monat prüefen
sStr = Mid(sDatum, 6, 2)
lLong = sStr
If Err.Number <> 0 Then GoTo AUFRAEUMEN
If Not (1 <= lLong And lLong <= 12) Then GoTo AUFRAEUMEN
->Tag prüefen
sStr = Mid(sDatum, 8, 2)
lLong = sStr
If Err.Number <> 0 Then GoTo AUFRAEUMEN
If Not (1 <= lLong And lLong <= 31) Then GoTo AUFRAEUMEN
IstEinDatum = True
AUFRAEUMEN:
Err.Clear: On Error GoTo 0
End Function
