Private WithEvents app As Application
Private Sub Document_Open()
Set app = Application
End Sub
Private Sub app_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
Dim sDatei As String, sPfad As String
Dim OriginalDatei As String, OriginalPfad As String
Dim GesPfad As String, fs As Object
If Doc Is ThisDocument Then
Set fs = CreateObject("Scripting.FileSystemObject")
If SaveAsUI = False Then
OriginalPfad = ActiveDocument.Path & "\"
OriginalDatei = ActiveDocument.Name
Else
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = ActiveDocument.Name
.FilterIndex = 2
If .Show = True Then
GesPfad = .SelectedItems(1)
OriginalPfad = Left(GesPfad, InStrRev(GesPfad, "\"))
OriginalDatei = Right(GesPfad, Len(GesPfad) - Len(OriginalPfad))
End If
End With
End If
sPfad = OriginalPfad & "Archiv\"
sDatei = Format(Now, "yyyyMMdd_hhmm_") & OriginalDatei
If Not fs.folderexists(sPfad) Then MkDir sPfad
ActiveDocument.SaveAs2 FileName:=sPfad & sDatei
ActiveDocument.SaveAs2 FileName:=OriginalPfad & OriginalDatei
Cancel = True
End If
End Sub