Karen,

This is gnarly but seems to work with a simple one section document.
Basically all I did was go to the footer and record a macro of the
steps to enter an IF field
(e,g, IF Page = NumPages"Insert Some Text") and applied the *\
Charformat switch so that the field result will display in the format
of the first character in the field.  Next I just plugged in your sting
in the "Insert Some Text" and viola!!

You can probably play with the code some and clean it up a bit:

Sub TruncPath()

Dim strFile As String
Dim strPath As String
Dim intLen As Integer
Dim intNumSlash As Integer
Dim strShortPath As String
Dim strFinal As String
Dim rngPlaceHolder As Range

strFile = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
strPath = ActiveDocument.Path
intLen = Len(strPath)
intNumSlash = InStrRev(strPath, "\")
strShortPath = Right(strPath, intLen - intNumSlash)

strFinal = strShortPath & "\" & strFile
Set rngPlaceHolder = Selection.Range
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="IF "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="Page"
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeText Text:=" = "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="NumPages"
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeText Text:="" & strFinal & ""
Selection.TypeText Text:="\* Charformat"
Selection.MoveLeft Unit:=wdCharacter, Count:=51
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
With Selection.Font
.Size = 7
End With
rngPlaceHolder.Select

End Sub

Karen,

I think this might be a better way.  Insert a field in your footer:

{ IF {PAGE } = { NUMPAGES } { DOCVARIABLE "Path" } \* Charformat}

Note: Format the "I" in "IF" as 7 point font

Now try this macro:
Sub TruncPath()

Dim strFile As String
Dim strPath As String
Dim intLen As Integer
Dim intNumSlash As Integer
Dim strShortPath As String
Dim strFinal As String
Dim rngPlaceHolder As Range

strFile = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
strPath = ActiveDocument.Path
intLen = Len(strPath)
intNumSlash = InStrRev(strPath, "\")
strShortPath = Right(strPath, intLen - intNumSlash)

strFinal = strShortPath & "\" & strFile

ActiveDocument.Variables.Add Name:="Path", Value:=strFinal
ActiveDocument.Fields.Update

End Sub

Karen,

I have monkeyed around with your question a bit more and I think that I have
it streamlined.  A true expert may be along to suggest that I don't
continually modify the same string.  We will see :-)

Sub TruncPath()

Dim oStory As Range
Dim myString As String

myString = ActiveDocument.FullName
myString = Left(myString, InStrRev(myString, ".") - 1)
myString = Right(myString, (Len(myString) - (Len(myString) _
          - (InStrRev(myString, "\") - 1))))

On Error Resume Next
ActiveDocument.Variables.Add Name:="Path", Value:=myString
ActiveDocument.Variables("Path").Value = myString
For Each oStory In ActiveDocument.StoryRanges
  oStory.Fields.Update
Next oStory

End Sub

Karen,

I had to go back to the drawing board.  After further testing I realized
that I had streamlined too much.  I tried to cancel the erroneous mesage,
but I don't know if will be removed before you view the posting.  Sorry for
any confusion.  Here is what I have now:
Sub TruncPath()

Dim oStory As Range
Dim MyFile As String
Dim MyPath As String
Dim myString As String

MyFile = ActiveDocument.Name
MyFile = Left(ActiveDocument.Name, InStrRev(MyFile, ".") - 1)
MyPath = ActiveDocument.Path
MyPath = Right(MyPath, Len(MyPath) - (InStrRev(MyPath, "\")))

myString = MyPath & "\" & MyFile

On Error Resume Next
ActiveDocument.Variables.Add Name:="Path", Value:=myString
ActiveDocument.Variables("Path").Value = myString
For Each oStory In ActiveDocument.StoryRanges
  oStory.Fields.Update
Next oStory

End Sub