Watermark

[Guest]

Using L Kittles code for a printable watermark....

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target <> Range("A1") Then Exit Sub
'On Error Resume Next
If Range("A1").Value = "x" Then

Dim Mud As Integer, Dum As Object
Mud = 190 '200
Application.ScreenUpdating = False
Dim Page As Integer
For Page = 1 To 1
ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, _
"D R A F T", "Algerian", _
30#, msoFalse, msoFalse, 155, 105#).Select
With Selection
.Name = "Dum"
.ShapeRange.Fill.Visible = msoTrue
.ShapeRange.Fill.Solid
.ShapeRange.Fill.ForeColor.SchemeColor = 22
.ShapeRange.Fill.Transparency = 0.5
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.IncrementRotation -26.22
.ShapeRange.IncrementTop Mud
End With

Next Page

Application.ScreenUpdating = True

ElseIf Range("A1").Value = "" Then
WaterMarkerGone
Exit Sub
End If

Range("A1").Select

End Sub

Sub WaterMarkerGone()
Application.ScreenUpdating = False
Dim Page As Integer
Dim Dum As Shape
For Page = 1 To 1
On Error Resume Next
ActiveSheet.Shapes("Dum").Select
Selection.Cut
Next Page
Application.ScreenUpdating = True
End Sub


When I enter X in A1 I dont get the watermark. I have enter the code in
This workbook module. I hae tried with the sheet protected and also without
protection. Any ideas?
Thanks in advance

 

[Lonnie M.]

Hi, I found a couple of things with the code you supplied and made
changes.
1) you were compairing the target object to the value of cell A1.
2) when I copied this into my editor from his example and yours it
brought in some dashes in the reserved words within word art portion of
the code. i.e. .ShapeRange.Fill.ForeColor.Sch­-emeColor = 22. this may
have affected your code in your editor as well.
I may have also changed a few other minor things, but this is what
worked for me:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)

Debug.Print ">>>>>>>>>>>>>>>>>>>>>>>>>>>>"
Debug.Print Target.Address(False, False)
Debug.Print Sh.Name
If Target.Address(False, False) <> "A1" Then Exit Sub
If Sh.Name <> "Sheet1" Then Exit Sub
'On Error Resume Next
If Range("A1").Value = "x" Then

Dim Mud As Integer, Dum As Object
Mud = 190 '200
Application.ScreenUpdating = False

ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, _
"D R A F T", "Algerian", _
30#, msoFalse, msoFalse, 155, 105#).Select
With Selection
.Name = "Dum"
.ShapeRange.Fill.Visible = msoTrue
.ShapeRange.Fill.Solid
.ShapeRange.Fill.ForeColor.SchemeColor = 22
.ShapeRange.Fill.Transparency = 0.5
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.IncrementRotation -26.22
.ShapeRange.IncrementTop Mud
End With

Application.ScreenUpdating = True

ElseIf Range("A1").Value = "" Then
WaterMarkerGone
Application.CutCopyMode = False
Exit Sub
End If

Range("A1").Select

End Sub


Public Sub WaterMarkerGone()
Application.ScreenUpdating = False
Dim Page As Integer
Dim Dum As Shape
For Page = 1 To 1
On Error Resume Next
ActiveSheet.Shapes("Dum").Sele­ct
Selection.Cut
Next Page
Application.ScreenUpdating = True
End Sub


HTH--Lonnie M.

 

[Darrin Henshaw]

This works for me, however, VB is case sensitive, so if I put a capital
X in A1 it won't work. However, it will work with a small x. Any other
info you have?

I would suggest adding Application.CutCopyMode = False, the end of your
WaterMarkerGone. Makes it a bit more seamless.

Darrin

 

[Tim Williams]

Works for me with no changes.

You're using a lower-case "x", right?

 

[Lonnie M.]

Disregard item 1--my eyes are a bit blurred, it is late in the day. I
must have blended a couple of lines together when I was reading it. I
would look to see if it inadvertently brought in the dashes when you
pasted the code in--as described in item 2.