How to delete VBA watermark on all slide? - vba

Question

Please can any one help in deleting the watermark in all slide in attached code. I am trying but got error.
Sub WaterMarkwide()
Dim intI As Integer
Dim intShp As Integer
Dim strWaterMark As String
strWaterMark = InputBox("Please Enter the text you want to appear as Watermark", _
"Enter Text Here:")
With ActivePresentation.Slides.Item(1)
.Shapes.AddLabel msoTextOrientationHorizontal, _
.Master.Width - 700, .Master.Width - 750, 20, 80
intShp = .Shapes.Count
.Shapes.Item(intShp).TextFrame.TextRange = strWaterMark
.Shapes.Item(intShp).TextEffect.FontName = Arial
.Shapes.Item(intShp).TextEffect.FontSize = 80
.Shapes.Item(intShp).TextEffect.PresetTextEffect = msoTextEffect1
.Shapes.Item(intShp).Rotation = 45
.Shapes.Item(intShp).Copy
End With
For intI = 2 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(intI)
.Shapes.PasteSpecial ppPastePNG
intShp = .Shapes.Count
End With
Next intI
End Sub

Answer 1

The key here is understanding that there is no "watermark" feature in PowerPoint, as there is in MS Word. The code you've used correctly adds a shape to each slide that can be used as a watermark (from this SO answer).
The problem is: how can you detect which shape is the "watermark" shape after it's been added?
For this solution, I modified your original code to add a Tag to each shape that acts as a watermark. Then, when you run the code to delete, it's easy to look for the tag, identify the shape as a watermark, and delete it.
Option Explicit
Const WATERMARK_TAG As String = "WATERMARK"
Const WATERMARK_VALUE As String = "Watermark"
Sub WaterMarkwide()
Dim strWaterMark As String
strWaterMark = InputBox("Please Enter the text you want to appear as Watermark", _
"Enter Text Here:")
Dim intShp As Integer
With ActivePresentation.Slides.Item(1)
.Shapes.AddLabel msoTextOrientationHorizontal, _
.Master.Width - 700, .Master.Width - 750, 20, 80
intShp = .Shapes.Count
End With
With ActivePresentation.Slides.Item(1).Shapes.Item(intShp)
.TextFrame.TextRange = strWaterMark
.TextEffect.FontName = "Arial"
.TextEffect.FontSize = 80
.TextEffect.PresetTextEffect = msoTextEffect1
.Rotation = 45
.Tags.Add WATERMARK_TAG, WATERMARK_VALUE
.Copy
End With
Dim intI As Integer
For intI = 2 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(intI)
Dim shp As Shape
.Shapes.PasteSpecial ppPastePNG
Set shp = .Shapes.Item(.Shapes.Count)
intShp = .Shapes.Count
shp.Tags.Add WATERMARK_TAG, WATERMARK_VALUE
End With
Next intI
End Sub
Sub DeleteWatermark()
Dim sld As Slide
For Each sld In ActivePresentation.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.Tags.Count > 0 Then
Dim value As String
value = shp.Tags.Item(WATERMARK_TAG)
If value = WATERMARK_VALUE Then
shp.Delete
End If
End If
Next shp
Next sld
End Sub