Why my watermark are placed in different positions in some pages?

[shanlau]

I have added the watermark in all pages of the document by VBA code. The code works fine in simple case but doesn't work well if there is long table across pages.


I have tested it in word2010 and office365, the results are slightly different but both of them are not ideal

result in word2010


result in word o365


Here is my code:

Sub Macro1()

 Call WaterMark_All("Remove")
 Selection.GoTo wdGoToPage, wdGoToAbsolute, 1
 Call WaterMark_All("Insert")

End Sub



Sub WaterMark_All(ByVal actiontype As String)
    Dim a, i
    a = ActiveDocument.BuiltInDocumentProperties("Number of Pages")

    For i = 1 To a
        If actiontype = "Insert" Then
            Call InsertWaterMark(i)
        Else
            Call RemoveWaterMark(i)
        End If

    Next
    
    Exit Sub
     
ErrHandler:
    MsgBox "An error occured trying to insert the watermark." & Chr(13) & _
    "Error Number: " & Err.Number & Chr(13) & _
    "Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
     
End Sub

Sub InsertWaterMark(ByVal page_num As Integer)
    
    If page_num = Selection.Information(wdActiveEndPageNumber) Then
    
        ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, _
        "DRAFT", "Arial", 1, False, False, 0, 0).Select
        With Selection.ShapeRange

            .Name = "Watermark_Page_" & page_num
            .TextEffect.NormalizedHeight = False
            .Line.Visible = False
                 
            With .Fill
                     
                .Visible = True
                .Solid
                .ForeColor.RGB = Gray
                .Transparency = 0.5
            End With
                 
            .LockAspectRatio = True
            .Height = InchesToPoints(2.42)
            .Width = InchesToPoints(6.04)
                 
            With .WrapFormat
                .AllowOverlap = True
                .Side = wdWrapNone
                .Type = 3
                     
            End With
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
            .Left = InchesToPoints(0)
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Top = InchesToPoints(0)

        End With
        Selection.GoToNext What:=wdGoToPage
    End If
    Exit Sub
    
ErrHandler:
    'MsgBox "Error in Insert Water Mark [Page" & page_num & "]"
End Sub



Sub RemoveWaterMark(ByVal page_num As Integer)
    Dim strWMName As String
    On Error GoTo ErrHandler
    strWMName = "Watermark_Page_" & page_num
    ActiveDocument.Shapes(strWMName).Select
    Selection.Delete
    Exit Sub
    
ErrHandler:
    'MsgBox "Error in Remove Water Mark [Page" & page_num & "]"
End Sub

Hope someone can help me to resolve the positioning issue