Why I don’t like the Watermark gallery in Word 2007

Introduction

Printed watermarks in Word 2003 worked fine for me. They appeared on every page of every section in a document. Regardless of whether or not you have link to previous in the headers. However in Word 2007 (and the Word 2010 Tech Preview) without Link to Previous checked, a watermark applied from the Gallery will only place itself into the section of the current selection. Luckily we still have the Custom Watermark dialog which behaves like it did in Word 2003. To remedy this stupid behaviour of the gallery I decided to write a fix button in VBA and add it to a custom ribbon tab.

It became obvious to me that these two methods of applying a watermark are run by completely separate internal routines. If you apply a watermark from the gallery then apply another from the dialog you end up with both watermarks (2010 tech preview has fixed this). Interestingly applying a watermark from the gallery always removes previous dialog and gallery watermarks first. But the dialog only removes watermarks inserted by itself, not the gallery.

We can deal with this problem in VBA by checking the Name of the Shapes in each Header in each Section. The watermark shape always begins with “PowerPlusWaterMarkObject”, followed by a number. This will range from a 7 to 9 digit number. If you’re a keen observer and aware of Shape Name limitations you’ll have realised that Shapes cannot have a string name longer than 32 characters in length. Unless, of course, you are Word. In that case you can name it longer! For the dialog watermarks the number increments by 1 for each additional shape in each header (Primary, First and Even) of each section.

Steps to replicate

1. Create a new document
2. From Page Layout > Page Setup > Breaks insert a Next Page Section Break
3. From Insert > Header & Footer > Header click Edit Header and uncheck Link to
   Previous, Different First Page and Different Odd & Even Pages
4. Click Close Header and Footer
5. From Page Layout, Page Background > Watermark select a watermark such as “Confidential”
   from the gallery

Result

You should now see that the Watermark you inserted only went into the section where your cursor is sitting. Note that even if you select the entire document or expand your selection the watermark will only be inserted in the section where the selection starts.

Workarounds

Workaround to populate the entire document a watermark

This workaround will copy the watermark to all headers of all sections, clean up any other watermarks left over, then rename the watermark shapes so that the dialog can recognise it. I’ve matched the odd way Word numbers its watermark shapes as you will see in the comments. A minor variation of this code is being used in production and appears to be working quite well.

Option Explicit

Private Const mstrcWatermarkName As String = "PowerPlusWaterMarkObject"
Private Const mstrcCustomWatermarkName As String = "MY_STAMP"
Private Const mintcWatermarkNameLength As Integer = 24

Public Sub WatermarkFix()

    ' This shape is the primary watermark which will be used to populate the
    ' remaining pages of the document.
    Dim shpWatermark As Shape

    Dim rngHeader As Range
    Dim objSection As Section
    Dim lngIndex As Long
    Dim hdrHeader As HeaderFooter
    Dim shpShape As Shape
    Dim strWatermark As String

    Dim shpsShapes As Collection
    Set shpsShapes = New Collection

    ' The assumption is that this fix will generally be applied immediatly after
    ' having inserted a watermark.
    ' First we check to see if a watermark has been inserted by one of the
    ' built in watermark options.
    ' To find a watermark we check the current page, then the current section,
    ' then the entire document.
    Set shpWatermark = CurrentPageWatermarks(mstrcWatermarkName)
    If shpWatermark Is Nothing Then
        Set shpWatermark = CurrentSectionWatermarks(mstrcWatermarkName)
    End If
    If shpWatermark Is Nothing Then
        Set shpWatermark = DocumentWatermarks(mstrcWatermarkName)
    End If

    ' If none of the above searches finds a watermark then there might have been
    ' one inserted by a custom function that doesn't use the default shape name
    ' for watermarks. Using the predefined string we'll search for that now.
    If shpWatermark Is Nothing Then
        Set shpWatermark = CurrentPageWatermarks(mstrcCustomWatermarkName)
    End If
    If shpWatermark Is Nothing Then
        Set shpWatermark = CurrentSectionWatermarks(mstrcCustomWatermarkName)
    End If
    If shpWatermark Is Nothing Then
        Set shpWatermark = DocumentWatermarks(mstrcCustomWatermarkName)
    End If

    ' If the above finds nothing then there are no watermarks that match the
    ' naming patterns we're expecting. Quit with a message.
    If shpWatermark Is Nothing Then
        MsgBox "No watermarks recognised" & vbCr & vbCr & _
        "If the document still contains a watermak" & vbCr & _
        "please remove manually." & vbCr & vbCr & _
        "Use Insert tab > Header > Edit header..." & vbCr & _
        "and delete the watermark image from all pages", _
        vbOKOnly, "No watarmarks recognised"
        Exit Sub
    End If

    ' The watermark has been found so now we need to adjust it so that it will
    ' print correctly on all printers.
    ' There is an issue when using a darker fill and transparency in that
    ' sometimes every second page will be missing the watermark. Another issue
    ' is that transparencies are sometimes printed with dithering even if the
    ' printer can usually print that tint of grey.
    If shpWatermark.Fill.ForeColor.RGB <> vbWhite And _
    shpWatermark.Fill.Transparency <> 0 Then
        shpWatermark.Fill.Transparency = 0
        shpWatermark.Fill.ForeColor.RGB = 14211288
    End If

    ' If the custom shapename was used for the watermark we need to rename it
    ' to the standard Office name. This will allow the built in watermark
    ' options to still find the watermarks. Some "developers" like to create
    ' custom names for their watermarks but this breaks the standard behaviour
    ' of MS Office and is a bad idea.
    If shpWatermark.Name Like mstrcCustomWatermarkName & "*" Then
        shpWatermark.Name = Replace(shpWatermark.Name, mstrcCustomWatermarkName, mstrcWatermarkName)
        shpWatermark.Name = Replace(shpWatermark.Name, "  ", "")
        shpWatermark.Name = Replace(shpWatermark.Name, " ", "")
    End If

    ' Check to see if the the primary watermark is in the primary header of
    ' the first section of the document. If it is not then we'll copy it there
    ' and re-set the primary watermark shape.
    If shpWatermark.Anchor.Sections(1).Index <> 1 Then
        Set rngHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
        rngHeader.Collapse wdCollapseStart
        rngHeader.FormattedText = shpWatermark.Anchor.FormattedText
    End If
    Set shpWatermark = DocumentWatermarks(shpWatermark.Name)

    ' Now that we have the watermark in the primary header of the first section
    ' we'll delete all the other watermarks we can find. This will provide a clean
    ' slate to work from so we can have complete control of the new watermarks.
    DeleteAllExcept shpWatermark

    ' Copy across watermark to all sections headers. For some reason the built
    ' in watermark dialog adds the watermarks to the headers starting with:
    ' First page header (2), Odd page header (3), then Primary page header (1).
    ' Formula to match:
    ' Let i = 1 to 3 : sequence = i mod 3 + 1 (can you tell I like math?)
    For Each objSection In ActiveDocument.Sections
        For lngIndex = 1 To 3
            Set hdrHeader = objSection.Headers(lngIndex Mod 3 + 1)
            If (hdrHeader.LinkToPrevious = False Or objSection.Index = 1) And _
            HeaderContainsWatermark(hdrHeader.Range) = False Then
                Set rngHeader = hdrHeader.Range
                rngHeader.Collapse wdCollapseStart
                rngHeader.FormattedText = shpWatermark.Anchor.FormattedText
                ' This might appear to be overwriting the header of each section
                ' but it actually keeps the existing range in tact and only adds
                ' the watermark to the range. This is because we're only using
                ' the anchor of the watermark and we're using rngHeader which
                ' has been collapsed to be 0 characters long.
            End If
        Next
    Next

    ' Now we will fix the naming since they're all named the same. Otherwise all
    ' shapes except the first will lose their name on save.
    ' To do this we will first build a collection of all the watermark shapes
    ' throughout the document.
    For Each objSection In ActiveDocument.Sections
        For lngIndex = 1 To 3
            Set hdrHeader = objSection.Headers(lngIndex Mod 3 + 1)
            For Each shpShape In hdrHeader.Range.ShapeRange
                If shpShape.Name Like mstrcWatermarkName & "*" Then
                    shpsShapes.Add shpShape
                End If
            Next
        Next
    Next

    ' Get the name of the primary watermark
    strWatermark = shpWatermark.Name

    ' Temporarily rename all the shapes since we could run into issues if we
    ' just do a straight rename. ie There is a chance we will try to name
    ' a shape in sequence where that index has already been used by chance
    ' elsewhere in the document.
    lngIndex = 0
    For Each shpShape In shpsShapes
        lngIndex = lngIndex + 1
        shpShape.Name = "Watermark Fix " & lngIndex
    Next

    ' Now sequence through and name each shape with a sequential index
    ' after the default watermark name.
    lngIndex = 0
    For Each shpShape In shpsShapes
        lngIndex = lngIndex + 1
        If shpShape.Name <> IncrementNameNumber(strWatermark, lngIndex) Then
            shpShape.Name = IncrementNameNumber(strWatermark, lngIndex)
        End If
    Next

End Sub

Private Function HeaderContainsWatermark(rngHeaderRange As Range) As Boolean

    ' Cycle through the specified range and look for a watermark.
    Dim shpShape As Shape
    For Each shpShape In rngHeaderRange.ShapeRange
        If shpShape.Name Like mstrcWatermarkName & "*" Or _
        shpShape.Name Like mstrcCustomWatermarkName & "*" Then
            HeaderContainsWatermark = True
            Exit Function
        End If
    Next

End Function

Private Function IncrementNameNumber(ByVal strString As String, lngAdd As Long) As String

    Dim strTempString As String
    Dim lngNumber As Long
    Dim lngNumberLength As Long
    Dim lngOffset As Long
    Dim i As Long

    If IsNumeric(Right(strString, 1)) = True Then
        lngOffset = Len(strString)
        ' This is needed because we cannot name a shape with more than
        ' 32 characters in VBA. However Word seems to be able to do
        ' this with no problem! How sneaky is that!
        If lngOffset > 32 Then lngOffset = 32
        i = lngOffset
        Do
            i = i - 1
        Loop While IsNumeric(Mid(strString, i)) = True
        lngNumberLength = lngOffset - i
        lngNumber = Right(strString, lngNumberLength)
        lngNumber = lngNumber + lngAdd
        strTempString = Left(strString, i)
        If lngNumberLength < 5 Then
            lngNumberLength = 5
        End If
        If Len(CStr(lngNumber)) > lngNumberLength Then
            lngNumber = lngNumber Mod (10 ^ lngNumberLength) + 1
        End If
        IncrementNameNumber = strTempString & Format(lngNumber, String(lngNumberLength, "0"))
    End If

End Function

Private Function StripNumber(strString As String) As String

    Dim lngNumberLength As Long
    Dim lngOffset As Long
    Dim i As Long

    If IsNumeric(Right(strString, 2)) = True Then
        lngOffset = Len(strString)
        i = lngOffset
        Do
            i = i - 1
        Loop While IsNumeric(Mid(strString, i)) = True
        lngNumberLength = lngOffset - i
        StripNumber = Right(strString, lngNumberLength)
    End If

End Function

Private Function DeleteAllExcept(shpKeepShape As Shape) As Shape

    Dim shpShape As Shape
    Dim lngIndex As Long

    For lngIndex = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.Count To 1 Step -1
        Set shpShape = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes(lngIndex)
        If (shpShape.Name Like mstrcWatermarkName & "*" Or _
        shpShape.Name Like mstrcCustomWatermarkName & "*") And _
        shpShape.ID <> shpKeepShape.ID Then
            shpShape.Delete
        End If
    Next
    For lngIndex = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Shapes.Count To 1 Step -1
        Set shpShape = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Shapes(lngIndex)
        If (shpShape.Name Like mstrcWatermarkName & "*" Or _
        shpShape.Name Like mstrcCustomWatermarkName & "*") And _
        shpShape.ID <> shpKeepShape.ID Then
            shpShape.Delete
        End If
    Next

End Function

Private Function DocumentWatermarks(strShapeName As String) As Shape

    Dim shpShape As Shape

    For Each shpShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
        If shpShape.Name Like strShapeName & "*" Then
            Set DocumentWatermarks = shpShape
            Exit For
        End If
    Next
    If DocumentWatermarks Is Nothing Then
        For Each shpShape In ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Shapes
            If shpShape.Name Like strShapeName & "*" Then
                Set DocumentWatermarks = shpShape
                Exit For
            End If
        Next
    End If
    If DocumentWatermarks Is Nothing Then
        For Each shpShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
            If shpShape.Name Like strShapeName & "*" Then
                Set DocumentWatermarks = shpShape
                Exit For
            End If
        Next
    End If
    If DocumentWatermarks Is Nothing Then
        For Each shpShape In ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Shapes
            If shpShape.Name Like strShapeName & "*" Then
                Set DocumentWatermarks = shpShape
                Exit For
            End If
        Next
    End If

End Function

Private Function CurrentSectionWatermarks(strShapeName As String) As Shape

    Dim objHeaderFooter As HeaderFooter
    Dim intIndex As Integer

    ' Check each header/footer pair for at least one watermark
    ' Start with First Page
    If Selection.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True Then
        With Selection.Sections(1).Headers(wdHeaderFooterFirstPage)
            Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
        End With
        If CurrentSectionWatermarks Is Nothing Then
            With Selection.Sections(1).Footers(wdHeaderFooterFirstPage)
                Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
            End With
        End If
    End If

    ' Then try Primary/Odd Page
    If CurrentSectionWatermarks Is Nothing Then
        With Selection.Sections(1).Headers(wdHeaderFooterPrimary)
            Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
        End With
        If CurrentSectionWatermarks Is Nothing Then
            With Selection.Sections(1).Footers(wdHeaderFooterPrimary)
                Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
            End With
        End If
    End If

    ' Then try Even Page
    If CurrentSectionWatermarks Is Nothing And _
    ActiveDocument.PageSetup.OddAndEvenPagesHeaderFooter = True Then
        With Selection.Sections(1).Headers(wdHeaderFooterEvenPages)
            Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
        End With
        If CurrentSectionWatermarks Is Nothing Then
            With Selection.Sections(1).Footers(wdHeaderFooterEvenPages)
                Set CurrentSectionWatermarks = RangeWatermarks(.Range, strShapeName)
            End With
        End If
    End If

End Function

Private Function CurrentPageWatermarks(strShapeName As String) As Shape

    Dim objViewType As WdViewType
    Dim objSeekView As WdSeekView
    Dim intIndex As Integer

    On Error GoTo Reset

    Application.ScreenUpdating = False
    If ActiveWindow.ActivePane.View.Type <> wdPrintView Then
        objViewType = ActiveWindow.ActivePane.View.Type
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        objViewType = wdPrintView
    End If

    objSeekView = ActiveWindow.ActivePane.View.SeekView

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.WholeStory
    Set CurrentPageWatermarks = RangeWatermarks(Selection.Range, strShapeName)

    If CurrentPageWatermarks Is Nothing Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
        Selection.WholeStory
        Set CurrentPageWatermarks = RangeWatermarks(Selection.Range, strShapeName)
    End If

    ActiveWindow.ActivePane.View.SeekView = objSeekView
    ActiveWindow.ActivePane.View.Type = objViewType
Reset:
    Application.ScreenUpdating = True

End Function

Private Function RangeWatermarks(rngRange As Range, strShapeName As String) As Shape

    Dim shpShape As Shape

    For Each shpShape In rngRange.ShapeRange
        If shpShape.Name Like strShapeName & "*" Then
            Set RangeWatermarks = shpShape
            Exit For
        End If
    Next

End Function

Workaround to fix as you apply

The following is a rough workaround able to capture the Watermark Gallery event and populate the rest of the document with the watermark. This will not fix watermarks left by the Gallery when applying a new watermark from the dialog as this event is only triggered by the gallery.

NOTE: I no longer use this code since it will only be invoked if it is in the ThisDocument module of the current template. The code I prefer is above and I simply use a button on the ribbon to run the routine it.

Option Explicit

Private Const mstrcWatermarkName As String = "PowerPlusWaterMarkObject"
Private Const mintcWatermarkNameLength As Integer = 24

Private Sub Document_BuildingBlockInsert(ByVal Range As Range, ByVal Name As String, ByVal Category As String, ByVal BlockType As String, ByVal Template As String)
    WatermarkWorkaround Range, Name, Category, BlockType, Template
End Sub

Public Sub WatermarkWorkaround(ByVal rngRange As Range, ByVal strName As String, ByVal strCategory As String, ByVal strBlockType As String, ByVal strTemplate As String)

    Dim objSection As Section
    Dim objHeader As HeaderFooter
    Dim rngHeader As Range
    Dim shpShape As Shape
    Dim lngIndex As Long
    Dim i As Long

    'Clean up any watermarks left over by mistake
    For lngIndex = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.Count _
    To 1 Step -1
        Set shpShape = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes(lngIndex)
        If Left(shpShape.Name, mintcWatermarkNameLength) = mstrcWatermarkName Then
            If shpShape.Name <> rngRange.ShapeRange(1).Name Then
                shpShape.Delete
            End If
        End If
    Next
    'Chop the name if it's longer than 32 characters because we cannot use longer strings
    'unlike the application!
    If Len(rngRange.ShapeRange(1).Name) > 32 Then
        rngRange.ShapeRange(1).Name = IncrementNameNumber(rngRange.ShapeRange(1).Name, 0)
    End If
    If strBlockType = "Watermarks" And Application.Version = "12.0" Then
        For Each objSection In ActiveDocument.Sections
            For Each objHeader In objSection.Headers
                If (objHeader.LinkToPrevious = False Or objSection.Index = 1) And _
                FirstRangeShapeNameInHeader(rngRange, objHeader) Is Nothing Then
                    Set rngHeader = objHeader.Range
                    rngHeader.Collapse wdCollapseStart
                    rngHeader.FormattedText = rngRange.FormattedText
                    Do
                        i = i + 1
                    Loop While IncrementFirstRangeShapeNameInHeader(rngRange, _
                    objHeader, i) = True
                End If
            Next
        Next
    End If

End Sub

Private Function FirstRangeShapeNameInHeader(ByVal rngRange As Range, _
ByVal objHeader As HeaderFooter) As Shape

    Dim objShape As Shape

    If rngRange.ShapeRange.Count > 0 Then
        For Each objShape In objHeader.Range.ShapeRange
            If Left(objShape.Name, mintcWatermarkNameLength) = mstrcWatermarkName Then
                Set FirstRangeShapeNameInHeader = objShape
                Exit Function
            End If
        Next
    End If

End Function

Private Function IncrementFirstRangeShapeNameInHeader(ByVal rngRange As Range, _
ByVal objHeader As HeaderFooter, Optional i As Long = 0) As Boolean

    Dim objShape As Shape

    If rngRange.ShapeRange.Count > 0 Then
        For Each objShape In objHeader.Range.ShapeRange
            If objShape.Name = rngRange.ShapeRange(1).Name Then
                objShape.Name = IncrementNameNumber(objShape.Name, i)
                IncrementFirstRangeShapeNameInHeader = True
                Exit Function
            End If
        Next
    End If

End Function

Private Function IncrementNameNumber(strString As String, lngAdd As Long) As String

    Dim lngNumber As Long
    Dim lngNumberLength As Long
    Dim lngLength As Long
    Dim i As Long

    If IsNumeric(Right(strString, 2)) = True Then
        lngLength = Len(strString)
        i = lngLength
        Do
            i = i - 1
        Loop While IsNumeric(Mid(strString, i)) = True
        lngNumberLength = lngLength - i
        lngNumber = Right(strString, lngNumberLength)
        'we need this because we cannot name a shape with more than 32 characters
        'however Word seems to be able to do this with no problem!
        If lngLength > 32 Then lngLength = 32
        lngNumber = lngNumber + lngAdd
        strString = Left(strString, i)
        If Len(CStr(lngNumber)) > lngNumberLength Then
            lngNumber = lngNumber Mod (10 ^ lngNumberLength) + 1
        End If
        IncrementNameNumber = strString & Format(lngNumber, String(lngNumberLength, "0"))
        Debug.Print IncrementNameNumber
    Else
        IncrementNameNumber = strString
    End If

End Function