How to remove watermark

[Bon]

Hello all

I created a watermark in each sheet. When I run my WatermarkGone macro,
all watermarks and pictures/graphics are removed. But, I want to remove
the watermark only. How can I do that? Please give me some advices.

Here are my Watermark and WatermarkGone code:

Sub WaterMarkerGone()
Dim intSheet As Integer
Dim wkBook As Workbook
Dim wkSheet As Worksheet
Dim intShape As Integer
Dim totalCount As Integer
Dim totalShapes As Integer

totalCount = ActiveWorkbook.Worksheets.Count
For intSheet = 1 To totalCount
Set wkSheet = ActiveWorkbook.Worksheets(intSheet)
totalShapes = wkSheet.Shapes.Count
Do While totalShapes > 0
wkSheet.Shapes(totalShapes).Delete
totalShapes = totalShapes - 1
Loop
Next intSheet
End Sub

Sub Watermark()
Dim wkSheet As Integer
Set myDocument = ActiveWorkbook

For wkSheet = 1 To ActiveWorkbook.Sheets.Count
Set myWatermark = myDocument.Worksheets(wkSheet).Shapes.AddTextEffect(
_
PresetTextEffect:=msoTextEffect2, _
Text:="Draft", _
FontName:="Arial Black", _
FontSize:=36, _
FontBold:=False, _
FontItalic:=False, _
Left:=318.75, _
Top:=159.75)
With myWatermark
Name = "Dum"
.IncrementRotation -43.46
.Fill.Visible = msoFalse
.Fill.Transparency = 0.5
.Fill.Solid
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 22
.Line.BackColor.RGB = RGB(255, 255, 255)
.ZOrder msoBringToFront
End With
Next wkSheet
End Sub

 

[Norman Jones]

Hi Bon,

Try:

'=============>>
Sub WaterMarkerGone()
Application.ScreenUpdating = False
Dim page As Integer
For page = 1 To Application. _
ExecuteExcel4Macro("GET.DOCUMENT(50)")
On Error Resume Next
ActiveSheet.Shapes("Dum").Select
Selection.Cut
Next page
Application.CutCopyMode = False
End Sub
'<<=============

 

[Bon]

Sub WaterMarkerGone()
Dim intSheet As Int eger
Dim wkBook As Workbook
Dim wkSheet As Worksheet
Dim intShape As Integer
Dim totalCount As Integer
Dim totalShapes As Integer
totalCount = ActiveWorkbook.Worksheets.Count
For intSheet = 1 To totalCount
Set wkSheet = ActiveWorkbook.Worksheets(intSheet)
totalShapes = wkSheet.Shapes.Count
If TypeName(Selection) = "Rectangle" Then 'New added
Do While totalShapes > 0
wkSheet.Shapes(totalShapes).Delete
totalShapes = totalShapes - 1
Loop
End If 'New added
Next intSheet
End Sub

I tried to put IF TypeName(Selection) = "Rectangle" Then 'Remove
watermark. But, the watermark doesn't be removed.

The suggested procedure doesn't remove watermarks in all worksheets as
well. Any other way I can try?

Please give me some suggestions.

Thanks
Bon
Norman Jones 寫é“：

 

[Norman Jones]

Hi Bon,

Try:

Sub WaterMarkerGone()
Dim SH As Worksheet
Dim shp As Shape

Application.ScreenUpdating = False

For Each SH In ActiveWorkbook.Worksheets
For Each shp In SH.Shapes
If shp.Name = "Dum" Then
shp.Delete
End If
Next shp
Next SH

Application.ScreenUpdating = True

End Sub
'<<=============


---
Regards,
Norman


Sub WaterMarkerGone()
Dim intSheet As Int eger
Dim wkBook As Workbook
Dim wkSheet As Worksheet
Dim intShape As Integer
Dim totalCount As Integer
Dim totalShapes As Integer
totalCount = ActiveWorkbook.Worksheets.Count
For intSheet = 1 To totalCount
Set wkSheet = ActiveWorkbook.Worksheets(intSheet)
totalShapes = wkSheet.Shapes.Count
If TypeName(Selection) = "Rectangle" Then 'New added
Do While totalShapes > 0
wkSheet.Shapes(totalShapes).Delete
totalShapes = totalShapes - 1
Loop
End If 'New added
Next intSheet
End Sub

I tried to put IF TypeName(Selection) = "Rectangle" Then 'Remove
watermark. But, the watermark doesn't be removed.

The suggested procedure doesn't remove watermarks in all worksheets as
well. Any other way I can try?

Please give me some suggestions.

Thanks
Bon
Norman Jones ??:

 

[Bon]

Hi Norman

The draft watermark can be removed. Thanks for you help.

Thanks
Bon