Option Explicit
 Sub FileSave()
 On Error Resume Next
 ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="OpenAt"
 ActiveDocument.Save
 InsertDocTitle
 End Sub

 Sub FileSaveAs()
 On Error Resume Next
 ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="OpenAt"
 Dialogs(wdDialogFileSaveAs).Show
 InsertDocTitle
 End Sub

 Sub AutoOpen()
 On Error Resume Next
     With ActiveWindow.View
         If Err.Number = 4248 Then Exit Sub
         .Type = wdPrintView
         .Zoom = 100
         .TableGridlines = True
     End With
     ActiveWindow.ActivePane.View.ShowAll = False
     ActiveWindow.ActivePane.View.ShowFieldCodes = False
     If ActiveDocument.Bookmarks.Exists("OpenAt") = True Then
         ActiveDocument.Bookmarks("OpenAt").Select
     End If
     InsertDocTitle
 End Sub

 Sub InsertDocTitle()
 ' Changes window title to include path with filename
     Dim NameArray As Variant
     Dim NameStringL As String
     Dim NameStringR As String
     Dim Count As Long
     Const maxLen = 120   ' set this value to fit your window width
     ' (avoid error if no active window)
     If Windows.Count > 0 Then
         NameStringL = ActiveDocument.FullName
         If Len(NameStringL) > maxLen Then
             ' separate the folder names
             NameArray = Split(NameStringL, "\")
             ' check the folder depth
             Count = UBound(NameArray)
             If Count > 3 Then
                 NameStringL = NameArray(0) & "\...\"
                 NameStringR = NameArray(Count)
                 Count = Count - 1

                 ' continue adding folders to the left of the string
                 ' until you run out of folders or one won't fit
                 Do While (Count > 0) And _
                    (Len(NameStringL) + Len(NameStringR) + _
                     Len(NameArray(Count)) < maxLen)
                     NameStringR = NameArray(Count) & "\" _
                                 & NameStringR
                     Count = Count - 1
                 Loop

                 NameStringL = NameStringL & NameStringR
             End If
         End If

         ' Change the window's caption
         ActiveWindow.Caption = NameStringL
     End If
 End Sub