The code below is to recursively refresh linked Excel objects in Microsoft Word.


Option Explicit

Sub Save_Draft()
    ' This subroutine saves the template with the "Draft" watermark intact.
    Const strFilePathNetwork As String = _
        "\\server\file share\directory1\"
    Const strFilePathWebsite As String = _
        "\\server\file share\directory2\"
    Const strFileNameDraft As String = _
        "Weekly Report_Draft.doc"
    Const strFileNameFinal As String = _
        "Weekly Report.doc"

    Dim msdate As String
    Dim x As String
    Dim DayAdj As Integer

    ' This sets current date to preferred format
    msdate = Format(Date, "yyyy-mm-dd")

    ' This converts current date to weekday, day of week
    DayAdj = Weekday(msdate, vbSunday)

    ' This will determine how many days since last Friday, the week ending reporting date
    Select Case DayAdj
        Case 1
            'Sunday
            DayAdj = 2
        Case 2
            'Monday
            DayAdj = 3
        Case 3
            'Tuesday
            DayAdj = 4
        Case 4
            'Wednesday
            DayAdj = 5
        Case 5
            'Thursday
            DayAdj = 6
        Case 6
            'Friday
            DayAdj = 7
        Case 7
            'Saturday
            DayAdj = 1
    End Select

    ' This determines last Friday's date no matter what the current date is
    x = Format(DateValue(msdate) - DayAdj, "yyyy-mm-dd")
    
    ' This selects everything
    Selection.WholeStory

    ' This updates all linked objects
    Selection.Fields.Update

    ' This returns to the first page; I should have created a bookmark and selected the bookmark!
    Selection.HomeKey Unit:=wdStory

    ' This saves the Word document template, then breaks all links and then saves a "dated" file with
    ' last Friday's date.  e.g.  2007-08-24 Report.doc
    ActiveDocument.Save
    Call Break_Links
    ActiveDocument.SaveAs FileName:=strFilePathNetwork + x + " " + strFileNameDraft
    Application.Quit
End Sub

Sub Save_Final()
    ' This subroutine saves the template with no "Draft" watermark.
    ' See previous subroutine for comments not shown below.  Code commented below differs from the previous code
    Const strFilePathNetwork As String = _
        "\\Server\Share\"
    Const strFilePathWebsite As String = _
        "\\Server\Share\"
    Const strFileNameDraft As String = _
        "Weekly Report_Draft.doc"
    Const strFileNameFinal As String = _
        "Weekly Report.doc"

    Dim msdate As String
    Dim x As String
    Dim DayAdj As Integer

    msdate = Format(Date, "yyyy-mm-dd")
    DayAdj = Weekday(msdate, vbSunday)
    Select Case DayAdj
        Case 1
            'Sunday
            DayAdj = 2
        Case 2
            'Monday
            DayAdj = 3
        Case 3
            'Tuesday
            DayAdj = 4
        Case 4
            'Wednesday
            DayAdj = 5
        Case 5
            'Thursday
            DayAdj = 6
        Case 6
            'Friday
            DayAdj = 7
        Case 7
            'Saturday
            DayAdj = 1
    End Select

    x = Format(DateValue(msdate) - DayAdj, "yyyy-mm-dd")

    Selection.WholeStory
    Selection.Fields.Update
    Selection.HomeKey Unit:=wdStory

    ActiveDocument.Save
    Call Break_Links

    ' This code will remove the "Draft" watermark.
    Call Remove_Watermark

    ActiveDocument.SaveAs FileName:=strFilePathNetwork + x + " " + strFileNameFinal
    Application.Quit
End Sub

Sub Break_Links()
    Dim iFld As Integer
    For iFld = ActiveDocument.Fields.Count To 1 Step -1
        With ActiveDocument.Fields(iFld)
                If .Type = wdFieldLink Then
                    .Unlink
                End If
        End With
    Next iFld
End Sub

Sub Remove_Watermark()
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes("WordArt 1").Select
    Selection.ShapeRange.Delete
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub