Hi,
I am trying to change watermark (for all pages), but the change takes several minutes. During this time Word XP (Windows 10) is non-responsive. I first tried the code that macro recorder records and then a code from another forum. The result is the same. Both codes work (in the end) but they both take several minutes to complete. Something is obviously amiss.
Any ideas, pls?
Thanks in advance for any kind help!
P
This is the product of macro-recorder:
This comes from forum (
I am trying to change watermark (for all pages), but the change takes several minutes. During this time Word XP (Windows 10) is non-responsive. I first tried the code that macro recorder records and then a code from another forum. The result is the same. Both codes work (in the end) but they both take several minutes to complete. Something is obviously amiss.
Any ideas, pls?
Thanks in advance for any kind help!
P
This is the product of macro-recorder:
Code:
Rem ActiveDocument.Sections(1).Range.Select
Rem ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Rem Selection.HeaderFooter.Shapes("WordPictureWatermark1").Select
Rem Selection.Delete
Rem ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddPicture(FileName:="D:\L2p1_white_010pcnt.png", LinkToFile:=False, SaveWithDocument:=True).Select
Selection.ShapeRange.Name = "WordPictureWatermark1"
Selection.ShapeRange.PictureFormat.Brightness = 0.85
Selection.ShapeRange.PictureFormat.Contrast = 0.15
Selection.ShapeRange.LockAspectRatio = True
Selection.ShapeRange.Height = CentimetersToPoints(25.1)
Selection.ShapeRange.Width = CentimetersToPoints(17.57)
Selection.ShapeRange.WrapFormat.AllowOverlap = True
Selection.ShapeRange.WrapFormat.Side = wdWrapNone
Selection.ShapeRange.WrapFormat.Type = 3
Selection.ShapeRange.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
Selection.ShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
Selection.ShapeRange.Left = wdShapeCenter
Selection.ShapeRange.Top = wdShapeCenter
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
This comes from forum (
Code:
Sub InsertWaterMark()
Dim strWMName As String
On Error GoTo ErrHandler
'selects all the sheets
ActiveDocument.Sections(1).Range.Select
strWMName = ActiveDocument.Sections(1).Index
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
'Change the text for your watermark here
Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1, _
"DRAFT", "Arial", 1, False, False, 0, 0).Select
With Selection.ShapeRange
.Name = strWMName
.TextEffect.NormalizedHeight = False
.Line.Visible = False
With .Fill
.Visible = True
.Solid
.ForeColor.RGB = Gray
.Transparency = 0.5
End With
.Rotation = 315
.LockAspectRatio = True
.Height = InchesToPoints(2.42)
.Width = InchesToPoints(6.04)
With .WrapFormat
.AllowOverlap = True
.Side = wdWrapNone
.Type = 3
End With
.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
'If using Word 2000 you may need to comment the 2
'lines above and uncomment the 2 below.
' .RelativeHorizontalPosition = wdRelativeVerticalPositionPage
' .RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = wdShapeCenter
.Top = wdShapeCenter
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Exit Sub
ErrHandler:
MsgBox "An error occured trying to insert the watermark." & Chr(13) & _
"Error Number: " & Err.Number & Chr(13) & _
"Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
End Sub