如何删除所有幻灯片上的VBA水印

Question

请任何人帮助删除所附代码中所有幻灯片中的水印。我正在尝试，但是出错了。

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

结束子

Answer 1

这里的关键是理解没有"水印"；功能，就像在MS Word中一样。你正确使用的代码为每张幻灯片添加了一个可以用作水印的形状(来自这个SO答案(。

问题是：你如何才能检测出哪种形状是"；水印"；添加后的形状？

对于这个解决方案，我修改了您的原始代码，为每个用作水印的形状添加了一个Tag。然后，当你运行要删除的代码时，很容易找到标签，将形状识别为水印，然后删除它

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