mddenapoli
04-17-2009, 04:34 AM
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
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