Solved: Water Mark Generator - Help!!

[mddenapoli]

In testing I am having difficulty because I dont know how to add a section to delete the watermark generated. Would it be permitted to ask for some assistance? :)


Sub InsertWaterMarks() 'Doc As Document, strText As String)
Dim sec As Section
Dim hdr As HeaderFooter
Dim sh As Shape
Dim i As Integer
Dim shHeaders As Shapes
Dim strText As String
Dim Doc As Document
Set Doc = ActiveDocument
strText = InputBox("Please enter text", "Watermark")
Set shHeaders = Doc.Sections(1).Headers(1).Shapes

'Delete any existing watermarks
For Each sec In Doc.Sections
For Each hdr In sec.Headers
For Each sh In hdr.Shapes
If InStr(sh.name, "PowerPlusWaterMarkObject") = 1 Then sh.Delete
Next sh
Next hdr
Next sec

'Add shape to headers shapes collection after selecting each header
For Each sec In Doc.Sections
For Each hdr In sec.Headers
i = i + 1
hdr.Range.Select
Set sh = shHeaders.AddTextEffect(msoTextEffect1, _
strText, "Times New Roman", 1, False, False, 0, 0)
sh.name = "PowerPlusWaterMarkObject" & i
sh.TextEffect.NormalizedHeight = False
sh.Line.Visible = False
sh.Fill.Visible = True
sh.Fill.Solid
sh.Fill.ForeColor.RGB = RGB(128, 128, 128) - 25
sh.Fill.Transparency = 0.75
sh.Rotation = 315
sh.LockAspectRatio = True
sh.Height = CentimetersToPoints(6.88)
sh.Width = CentimetersToPoints(13.77)
sh.WrapFormat.AllowOverlap = True
sh.WrapFormat.Side = wdWrapNone
sh.WrapFormat.Type = 3
sh.RelativeHorizontalPosition = _
wdRelativeVerticalPositionMargin
sh.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
sh.Left = wdShapeCenter
sh.Top = wdShapeCenter
Next hdr
Next sec
End Sub

[Paul_Hossler]

Hi again - you have the code already in your macro

Just pull it out and make into a standalone sub. It will only work with Shapes that have the "PowerPlus" - type name

Others might have additional suggestions about ways to do it faster, but this seems to work OK, at least for "normal" sized documents

Don't forget to test with the different types of H/F layouts (diff first page, odd/even) to make sure your macro is doing what you want.



Sub DeleteWaterMarks()
Dim sec As Section
Dim hdr As HeaderFooter
Dim sh As Shape
Dim shHeaders As Shapes
Dim Doc As Document

If MsgBox("Are you sure you want to delete all watermarks", _
vbQuestion + vbYesNo + vbDefaultButton2, "Delete Watermarks") = vbNo Then
Exit Sub
End If


Set Doc = ActiveDocument

'Delete any existing watermarks
For Each sec In Doc.Sections
For Each hdr In sec.Headers
For Each sh In hdr.Shapes
If InStr(sh.Name, "PowerPlusWaterMarkObject") = 1 Then sh.Delete
Next sh
Next hdr
Next sec
End Sub



Paul

[fumei]

Paul: "Don't forget to test with the different types of H/F layouts (diff first page, odd/even) to make sure your macro is doing what you want."

That is not needed. Your code covers all headers, whether they are being used, or not.
For Each hdr In sec.Headers

Even if DifferentFirstPage is OFF, its header will, in fact, be actioned.

Your code does delete ALL watermarks in ALL headers.