Private Sub Document_Open()
  ActiveDocument.Fields.Update
End Sub

Sub UpdateAllFields()

Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
    oStory.Fields.Update
    If oStory.StoryType <> wdMainTextStory Then
        While Not (oStory.NextStoryRange Is Nothing)
            Set oStory = oStory.NextStoryRange
            oStory.Fields.Update
        Wend
    End If
Next oStory
Set oStory = Nothing
End Sub

Sub RefreshFields(Doc As Document)
Dim TOC As TableOfContents  ' Table of Contents Object
Dim TOA As TableOfAuthorities ' Table of Authorities Object
Dim TOF As TableOfFigures ' Table of Figures Object
Dim pRange As Range ' Word Range Object
With Doc
  ' Loop through Story Ranges and update.
  ' Note that this may trigger interactive fields (eg ASK and FILLIN).
  For Each pRange In .StoryRanges
    Do
      pRange.Fields.Update
      Set pRange = pRange.NextStoryRange
    Loop Until pRange Is Nothing
  Next
' The following routines are necessary because the foregoing updates only page numbers
' in TOCs, TOAs and TOFs - field updating doesn't update TOC, TOA or TOF contents.
  ' Loop through Tables Of Contents and update
  For Each TOC In .TablesOfContents
    TOC.Update
  Next
  ' Loop through Tables Of Authorities and update
  For Each TOA In .TablesOfAuthorities
    TOA.Update
  Next
  ' Loop through Tables Of Figures and update
  For Each TOF In .TablesOfFigures
    TOF.Update
  Next
End With
Call AcceptTrackedFields(Doc)
End Sub
 
Sub AcceptTrackedFields(Doc As Document)
'This sub accepts any tracked changes affecting fields
Dim oRng As Range, oFld As Field
With Doc
  ' Loop through all range objects and accept tracked changes on fields
  For Each oRng In .StoryRanges
    Do
      For Each oFld In oRng.Fields
        oFld.Select
        Selection.Range.Revisions.AcceptAll
      Next
      Set oRng = oRng.NextStoryRange
    Loop Until oRng Is Nothing
  Next
End With
End Sub
 
Private Sub Document_Close()
Dim bSaved As Boolean
bSaved = ActiveDocument.Saved
Call RefreshFields(ActiveDocument)
If bSaved = True And ActiveDocument.Saved = False Then ActiveDocument.Save
End Sub
 
Private Sub Document_Open()
Call RefreshFields(ActiveDocument)
End Sub

Public WithEvents wdApp As Word.Application
Public WithEvents wdDoc As Word.Document

Dim wdAppClass As New ThisApplication
Public Sub AutoExec()
Set wdAppClass.wdApp = Word.Application
End Sub

Private Sub wdApp_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
Call RefreshFields(ActiveDocument)
End Sub
 
Private Sub wdApp_DocumentBeforeSave(ByVal Doc As Document, Cancel As Boolean)
Call RefreshFields(ActiveDocument)
End Sub