Insert watermark in Word Documents

Question

I am seeking a way to insert a watermark into Word documents. Here is the code I get by recording Macros,

Sub add_watermark()
'
' Macro2 Macro
'
'
    ActiveDocument.Sections(1).Range.Select
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddTextEffect( _
        PowerPlusWaterMarkObject354239640, "PAID", "arial", 1, False, False, 0, 0 _
        ).Select
    Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640"
    Selection.ShapeRange.TextEffect.NormalizedHeight = False
    Selection.ShapeRange.Line.Visible = False
    Selection.ShapeRange.Fill.Visible = True
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
    Selection.ShapeRange.Fill.Transparency = 0
    Selection.ShapeRange.Rotation = 315
    Selection.ShapeRange.LockAspectRatio = True
    Selection.ShapeRange.Height = CentimetersToPoints(9.31)
    Selection.ShapeRange.Width = CentimetersToPoints(13.96)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.Top = wdShapeCenter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

But I have an "out of range" error after running the Macro in another document. When I debug it, this line "Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640" is highlighted.

Does anyone know how to tackle it?

Thanks,

Answer 1

Try something based on:

Sub AddPaidWatermark()
Application.ScreenUpdating = False
Dim sWdth As Single, Shp As Shape
With ActiveDocument.Sections(1)
  With .PageSetup
    sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
  End With     
    With .Headers(wdHeaderFooterPrimary)
      If .Range.Characters.First.Information(wdWithInTable) = True Then
        With .Range.Tables(1)
          .Rows.Add .Rows(1)
          .Split .Rows(2)
        End With
        .Range.Tables(1).Delete
        .Range.Paragraphs(1).Range.Font.Hidden = True
      End If
      Set Shp = .Shapes.AddTextEffect(msoTextEffect1, "PAID", "Arial", 1, False, False, 0, 0)
    End With
  With Shp
    .WrapFormat.Type = wdWrapBehind
    .ZOrder msoBringToFront
    .Height = sWdth / 2 ^ 0.5
    .Width = .Height
    .Rotation = 315
    .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
    .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
    .Left = wdShapeCenter
    .Top = wdShapeCenter
    With .Fill
      .Visible = True
      .Solid
      .ForeColor.RGB = RGB(192, 192, 192)
    End With
  End With
End With
Application.ScreenUpdating = True
End Sub