Watermark

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

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=AD-emeColor =3D 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 =3D "x" Then

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

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

Application.ScreenUpdating =3D True

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

Range("A1").Select

End Sub


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


HTH--Lonnie M.

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


*** Sent via Developersdex http://www.developersdex.com ***

Works for me with no changes.

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

--
Tim Williams
Palo Alto, CA


"Steve" <[email protected]> wrote in message
news:[email protected]...
> 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

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.