To answer the need of Rich Lysakowski (and mine too), here is a different approach which preserves history! (it actually closes and reopens the file)
Sub RenameActiveFile()
Dim strFileFullName, strFilePath, strFileName, strFileExt, strNewName, strNewFullName As String
Dim result As VbMsgBoxResult
'check if it is a new file which has never been saved
If ActiveDocument.Path = "" Then
On Error Resume Next 'to avoid VBA error if cancel is pressed
ActiveDocument.Save
Exit Sub
End If
' Get current name:
strFileFullName = ActiveDocument.FullName 'for Word docs
strFilePath = ActiveDocument.Path 'Left(strFileFullName, InStrRev(strFileFullName, "\"))
strFileName = Left(ActiveDocument.Name, (InStrRev(ActiveDocument.Name, ".") - 1)) ' strip extension
strFileExt = Mid(ActiveDocument.Name, (InStrRev(ActiveDocument.Name, ".") + 1)) 'get extension
If Not (ActiveDocument.Saved) Then
result = MsgBox("""" & strFileName & """ needs to be saved before renaming." & vbCrLf & "Save """ & strFileName & """ ?" & strNewName, _
vbQuestion + vbYesNo, "Document not saved")
If result = vbNo Then Exit Sub
ActiveDocument.Save
End If
' Prompt for new name:
strNewName = InputBox("Rename """ & strFileName & """ to:" & vbCrLf & "(do not type extension: ""." & strFileExt & """ will be added)", _
"Rename File", strFileName)
'Check whether user cancelled
If (strNewName = "") Or (strNewName = strFileName) Then
Exit Sub
Else
strNewFullName = strFilePath & "\" & strNewName & "." & strFileExt
End If
'check if new name exist (not working with online files)
If Dir(strNewFullName) > "" Then
result = MsgBox("A file """ & strNewName & """ already exist in the same folder!", vbExclamation, "Renaming failed")
Exit Sub
End If
'close, rename and reopen file
ActiveDocument.Close
Name strFileFullName As strNewFullName
Documents.Open FileName:=strNewFullName
End Sub