Option Explicit
Sub Speichern_unter()
Dim strFileName As String
strFileName = NextFileIndexName("S:\Physikalische Therapie\Protokolle", "Protokoll Teambesprechung_" & Format(Date, "yyyy_mm_dd") & " (($)).docx", "0", 1)
If Len(strFileName) Then ActiveDocument.SaveAs2 strFileName, wdFormatXMLDocument
End Sub
Private Function NextFileIndexName(ByVal FilePath As String, ByVal FileNamePattern As String, Optional ByVal IndexFormat As _
String = "-0", Optional ByVal StartIndex As Long = 0, Optional ByVal ShowNullIndex As Boolean = True) As String
Dim varFile As Variant, strCheck As String, strIndex As String, strTemp As String, lngIndex As Long
Const PLACEHOLDER As String = "($)"
On Error GoTo ErrorHandler
If InStr(1, FileNamePattern, PLACEHOLDER) = 0 Then GoTo ErrorHandler
If Len(FileNamePattern) <> Len(Replace(FileNamePattern, PLACEHOLDER, "")) + Len(PLACEHOLDER) Then GoTo ErrorHandler
If Dir(FilePath, vbDirectory) = "" Then GoTo ErrorHandler
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
varFile = Split(FileNamePattern, PLACEHOLDER)
lngIndex = StartIndex
Do
If lngIndex = 0 And ShowNullIndex Then
strIndex = Format(lngIndex, IndexFormat)
ElseIf lngIndex > 0 Then
strIndex = Format(lngIndex, IndexFormat)
End If
lngIndex = lngIndex + 1
strTemp = FilePath & varFile(0) & strIndex & varFile(1)
strCheck = Dir(strTemp, vbNormal)
Loop Until strCheck = ""
NextFileIndexName = strTemp
Exit Function
ErrorHandler:
NextFileIndexName = ""
End Function