Hallo Tim,
Probiere es mit einer Routine (in normal.dot oder globalem Add-In) wie folgt:
Sub SpeichernMitUsernameUndDatum()
If Documents.Count Const TITEL = "Dokument speichern mit Username und Datum"
Dim objDok As Document
Dim strOldName As String, strNewName As String, strPath As String
Dim blnNoSaveAs As Boolean
On Error Resume Next
Set objDok = ActiveDocument
With objDok
strPath = .Path
If strPath = "" Then
MsgBox Chr(34) & .Name & Chr(34) & " wurde noch nicht gespeichert." _
& vbCrLf & vbCrLf & "Speichern Sie das Dokument zunächst mit normalen Namen.", vbInformation, TITEL
Dialogs(wdDialogFileSaveAs).Show
Exit Sub
End If
strOldName = .Name
If InStr(strOldName, " " & Environ("USERNAME") & " " & Format(Date, "dd.mm.yyyy")) Then
strNewName = strOldName
Else
strNewName = Left(.Name, Len(.Name) - 4)
' sollte Environ("USERNAME") nicht zuverlässig sein, müsste eine WIN-API her
strNewName = strNewName & " " & Environ("USERNAME") & " " & Format(Date, "dd.mm.yyyy") & Right(strOldName, 4)
End If
If Right(strPath, 1) Application.PathSeparator Then strPath = .Path & Application.PathSeparator
strNewName = strPath & strNewName
If Dir(strNewName) "" Then
If MsgBox(Chr(34) & strNewName & Chr(34) & " existiert bereits." _
& vbCrLf & vbCrLf & "Soll die Datei überschrieben werden?", vbQuestion + vbYesNo + vbDefaultButton2, TITEL) _
= vbNo Then blnNoSaveAs = True
End If
If Not blnNoSaveAs Then .SaveAs strNewName ' ggf. weitere Parameter
If Err 0 Then
MsgBox "Es ist ein Fehler aufgetreten:" _
& vbCrLf & vbCrLf & Err.Description, vbCritical, TITEL
End If
End With
End Sub
Bedenke ggf., dass so diese Version das akt. Dok wird und die vorherige ggf. nicht mit aktuellem Inhalt gespeichert ist (was aber noch einbaubar wäre).
Wenn das gut funktioniert, kannst du dir für das Makro über "Extras- Anpassen - Befehle - Makros" einen Button und/oder Menüpunkt anlegen und diesen ggf. noch anpassen. Diese Anpassung sollte in der gleichen *.dot erfolgen (Listenfeld im Dialog beachten)
Gruß
Uli