VBA code to align watermarks

[Catty]

Hi, I have used some code from the net to insert watermarks, but need help to position these watermarks on the document correctly. Below is the code used to insert these watermarks.

    Set Shp = HdFt.Shapes.AddTextEffect(msoTextEffect1, _
    "CONFIDENTIAL", "Arial Narrow", 38, False, False, 0, 0)
    With Shp
      .Name = "PowerPlusWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00")
      .TextEffect.NormalizedHeight = False
      .Line.Visible = False
      .Fill.Visible = True
      .Fill.Solid
      .Fill.ForeColor.RGB = RGB(192, 192, 192)
      .Fill.Transparency = 0.5
      .Rotation = 315
      .LockAspectRatio = True
      .Height = InchesToPoints(3.29)
      .Width = InchesToPoints(6.85)
      .WrapFormat.AllowOverlap = True
      .WrapFormat.Side = wdWrapNone
      .Left = InchesToPoints(-0.5)
      .WrapFormat.Type = 3
      .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
      .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
      .Top = InchesToPoints(3)
    End With
    .Range.FormattedText.ShowAll = False
  Next
End With

Thanks!

[gmaxey]

The code you posted will not run or compile. What help do you need. Where do you want the WM positioned?

[Catty]

Hi Greg,

I need the WM alignment to be vertically and horizontally centered relative to page. I did not include all the code in my previous post. Below is the complete code.

Dim Shp As Shape, HdFt As HeaderFooter 
With ActiveDocument 
  On Error Goto Errhandler 
   'Add the watermark to each header in the first Section
  With .Sections.First 
    For Each HdFt In .Headers 
      Set Shp = HdFt.Shapes.AddTextEffect(msoTextEffect1, _ 
      "CONFIDENTIAL", "Arial Narrow", 38, False, False, 0, 0) 
      With Shp 
        .Name = "PowerPlusWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00") 
        .TextEffect.NormalizedHeight = False 
        .Line.Visible = False 
        .Fill.Visible = True 
        .Fill.Solid 
        .Fill.ForeColor.RGB = RGB(192, 192, 192) 
        .Fill.Transparency = 0.5 
        .Rotation = 315 
        .LockAspectRatio = True 
        .Height = InchesToPoints(3.29) 
        .Width = InchesToPoints(6.85) 
        .WrapFormat.AllowOverlap = True 
        .WrapFormat.Side = wdWrapNone 
        .Left = InchesToPoints(-0.5) 
        .WrapFormat.Type = 3 
        .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin 
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin 
        .Top = InchesToPoints(3) 
      End With 
      .Range.FormattedText.ShowAll = False 
    Next 
  End With 
  With .ActiveWindow.View 
    .ShowMarkupAreaHighlight = False 
    .ShowComments = False 
    .ShowRevisionsAndComments = False 
  End With 
  .FormattingShowClear = True 
End With 
Set Shp = Nothing

[gmaxey]

Sub ScratchMacro() 
   'A basic Word macro coded by Greg Maxey
  Dim Shp As Shape, HdFt As HeaderFooter 
  With ActiveDocument 
     'Add the watermark to each header in the first Section
    With .Sections.First 
      For Each HdFt In .Headers 
        Set Shp = HdFt.Shapes.AddTextEffect(msoTextEffect1, _ 
        "CONFIDENTIAL", "Arial Narrow", 38, False, False, 0, 0) 
        With Shp 
          .Name = "PowerPlusWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00") 
          .TextEffect.NormalizedHeight = False 
          .Line.Visible = False 
          .Fill.Visible = True 
          .Fill.Solid 
          .Fill.ForeColor.RGB = RGB(192, 192, 192) 
          .Fill.Transparency = 0.5 
          .Rotation = 315 
          .LockAspectRatio = True 
          .Height = InchesToPoints(3.29) 
          .Width = InchesToPoints(6.85) 
          .WrapFormat.AllowOverlap = True 
          .WrapFormat.Side = wdWrapNone 
          .WrapFormat.Type = 3 
          .RelativeHorizontalPosition = wdRelativeVerticalPositionPage 
          .RelativeVerticalPosition = wdRelativeVerticalPositionPage 
          .Left = wdShapeCenter 
          .Top = wdShapeCenter 
        End With 
        .Range.FormattedText.ShowAll = False 
      Next 
    End With 
    With .ActiveWindow.View 
      .ShowMarkupAreaHighlight = False 
      .ShowComments = False 
      .ShowRevisionsAndComments = False 
    End With 
    .FormattingShowClear = True 
  End With 
  Set Shp = Nothing 
End Sub

[Catty]

Thanks a lot Greg...this works beautifully.

I have two other concerns though. I have created a DeleteWaterMark macro which was working 100% first run, but now
after inserting my "new" watermark, I have to run the DeleteWaterMark macro twice before the watermark is removed.

Also for testing purposes, when I try to insert 2 different watermarks on the same document, the second watermark
"hangs" on the top half of the header instead of just replacing the first one (hope I'm making sense).
How can I resolve this? Below is the DeleteWaterMark macro. Thanks so much for your help!

Sub DeleteWatermark() 
  Dim oSection As section 
  Dim oHeader As HeaderFooter 
  Dim oRng As Range 
  Dim oShape As Shape 
  On Error Goto Errhandler 
  For Each oSection In ActiveDocument.Sections 
    For Each oHeader In oSection.Headers 
      If oHeader.Exists Then 
        Set oRng = oHeader.Range 
        oRng.End = oRng.Paragraphs(1).Range.End - 1 
        For Each oShape In oRng.ShapeRange 
          If oShape.Type = 15 Then oShape.Delete 
        Next oShape 
      End If 
    Next oHeader 
  Next oSection 
   
Errhandler: 
  MsgBox "Watermark successfully removed." 
End Sub

[gmaxey]

Catty,

For Each loops when dealing with objects and deleting is often problematic. Also before inserting watermarks you should ensure the previous ones are deleted first by adding a call to your delete macro:

Sub ScratchMacro() 
   'A basic Word macro coded by Greg Maxey
  Dim Shp As Shape, HdFt As HeaderFooter 
  DeleteWatermark 
  With ActiveDocument 
     'Add the watermark To each header In the first Section
    With .Sections.First 
      For Each HdFt In .Headers 
        Set Shp = HdFt.Shapes.AddTextEffect(msoTextEffect1, _ 
        "CONFIDENTIAL", "Arial Narrow", 38, False, False, 0, 0) 
        With Shp 
          .Name = "PowerPlusWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00") 
          .TextEffect.NormalizedHeight = False 
          .Line.Visible = False 
          .Fill.Visible = True 
          .Fill.Solid 
          .Fill.ForeColor.RGB = RGB(192, 192, 192) 
          .Fill.Transparency = 0.5 
          .Rotation = 315 
          .LockAspectRatio = True 
          .Height = InchesToPoints(3.29) 
          .Width = InchesToPoints(6.85) 
          .WrapFormat.AllowOverlap = True 
          .WrapFormat.Side = wdWrapNone 
          .WrapFormat.Type = 3 
          .RelativeHorizontalPosition = wdRelativeVerticalPositionPage 
          .RelativeVerticalPosition = wdRelativeVerticalPositionPage 
          .Left = wdShapeCenter 
          .Top = wdShapeCenter 
        End With 
        .Range.FormattedText.ShowAll = False 
      Next 
    End With 
    With .ActiveWindow.View 
      .ShowMarkupAreaHighlight = False 
      .ShowComments = False 
      .ShowRevisionsAndComments = False 
    End With 
    .FormattingShowClear = True 
  End With 
  Set Shp = Nothing 
End Sub 
 
Sub DeleteWatermark() 
  Dim oSection As Section 
  Dim oHeader As HeaderFooter 
  Dim oShape As Shape 
  Dim lngIndex As Long 
  For Each oSection In ActiveDocument.Sections 
    For lngIndex = 1 To 3 
      Set oHeader = oSection.Headers(lngIndex) 
      For Each oShape In oHeader.Range.ShapeRange 
        If oShape.Type = 15 Then oShape.Delete 
      Next oShape 
    Next lngIndex 
  Next 
  oSection 
End Sub

[macropod]

Hi folks,

When posting code, please use the code tags. They're on the 'Go Advanced' tab. Doing this will preserve the code's structure and make it much easier for everyone reading your posts to understand what your code is doing.

I've edited all your code posts in this thread to that end.

[gmaxey]

Paul,

Sorry, I should have known (did actually know) that. I was just in a hurry and missed it this time.

[Catty]

Thanks so much for all your help Greg. Much appreciated, both macros work wonderfully. Thanks again