S
Steve
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
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