Microsoft Office Forums - View Single Post

gmayor · 08-21-2015, 05:10 AM

You can do it with a macro (or macros), and it helps to move the QAT (Quick Access Toolbar) below the ribbon, to provide more space.

The following is what I use in my systems. You may not need all the options, but you can delete those you don't. Insert a new module in the normal template, call it (say) modAutoMacros and add the following macro code.
http://www.gmayor.com/installing_macro.htm

Because of the availability of very long filenames, the path length may have to be curtailed to fit the available space. I have it set at 120 characters. You may need to change that.

Code:

Option Explicit
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
lbl_Exit:
    Exit Sub
End Sub

Sub AutoNew()
    With ActiveWindow.View
        .Type = wdPrintView
        .TableGridlines = True
        .Zoom = 100
        .ShowFieldCodes = False
        .ShowAll = False
    End With
    ActiveWindow.ActivePane.View.ShowAll = False
lbl_Exit:
    Exit Sub
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
lbl_Exit:
    Exit Sub
End Sub