По предложению @Adam и @ Lưu Vĩnh Phúc я создал следующий макрос, который выполняет то, что вы просили. Обратите внимание, что это удалит любую историю, связанную с файлом.
Sub RenameActiveFile()
'
' Renames the current file without closing the document (assuming file has already been saved)
' (Actually, saves with new name and deletes previous, so history will be lost).
'
Dim strFileFullName, strFileName, strNewName As String
Dim res As VbMsgBoxResult
' Get current name:
strFileFullName = ActiveDocument.FullName 'for Word docs
'strFileFullName = ActiveWorkbook.FullName 'for Excel docs
'strFileFullName = Application.ActivePresentation.FullName 'for Powerpoint presentations*
If (InStr(strFileFullName, ".") = 0) Then
res = MsgBox("File has not been saved. Can't rename it.", , "Rename File")
Exit Sub
End If
strFileName = Right(strFileFullName, Len(strFileFullName) - InStrRev(strFileFullName, "\")) 'strip path
strFileName = Left(strFileName, (InStr(strFileName, ".") - 1)) ' strip extension
' Prompt for new name:
strNewName = InputBox("Rename this file to:", "Rename File", strFileName)
If (strNewName = "") Or (strNewName = strFileName) Then ' (Check whether user cancelled)
Exit Sub
End If
' Save file with new name:
ActiveDocument.SaveAs2 FileName:=strNewName 'for Word docs
'ActiveWorkbook.SaveAs2 FileName:=strNewName 'for Excel docs
'Application.ActivePresentation.SaveAs FileName:=strNewName 'for Powerpoint presentations*
' Delete old file:
With New FileSystemObject ' (this line requires: Tools->References->Microsoft scripting runtime)
If .FileExists(strFileFullName) Then
.DeleteFile strFileFullName
End If
End With
End Sub
* Примечание: хотя этот макрос работает с Powerpoint (с изменениями, отмеченными выше), PowerPoint не может сохранить его глобально.