Private Sub Document_Close()
Call FileSave
SendKeys "{ESC}"
End Sub
 
Sub FileSave()
Dim BackupPath As String, objF As Object, retVal As Long, Rslt
BackupPath = "C:\Users\" & Environ("UserName") & "\Documents\BackupWord\"
With ActiveDocument
  If .Path = "" Then: If Application.Dialogs(wdDialogFileSaveAs).Show <> -1 Then Exit Sub
  If .Saved = False Then
    Rslt = MsgBox("Do you want to Save Changes?", vbYesNoCancel, "File Save")
    If Rslt = vbNo Then
      .Saved = True
      Exit Sub
    ElseIf Rslt = vbCancel Then
      Exit Sub
    End If
  End If
  .Save
  If Dir(BackupPath, vbDirectory) = "" Then
    MkDir BackupPath
    MsgBox "Backup folder has been created.", vbInformation
  End If
  If .Path & "\" = BackupPath Then
    MsgBox "WARNING! Backup folder is the same as the source folder", vbExclamation
    Exit Sub
  End If
  Set objF = CreateObject("Scripting.FileSystemObject")
  retVal = -1
  On Error Resume Next
  retVal = objF.CopyFile(.FullName, BackupPath & .Name, True)
  On Error GoTo 0
  Set objF = Nothing
  If retVal <> 0 Then MsgBox "Backup has not been copied to folder " & BackupPath, vbExclamation
End With
End Sub