watermark change takes minutes (Word XP) 1

[565u]

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:

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 (

http://www.vbaexpress.com/kb/getarticle.php?kb_id=588):

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

 

[Gavona]

Could this be to do with the printer? Try changing the active printer to "Microsoft XPS Document Writer" and switching off any settings that require Word to paginate etc.
Application.ScreenUpdating = False

Gavin

 

[Andrzejek]

I would put a break at the top of this code and step thru it, detecting which line(s) take the most time to execute.


---- Andy

There is a great need for a sarcasm font.

 

[565u]

Thank you both very much for your kind replies!
I started with switching the printer from CutePDF to "Microsoft XPS Document Writer" and the code ran quickly. Going back to CutePDF did not bring back the long waiting time though. I will explore more and will note here if I solve this.
Best regards!

P

 

[Gavona]

I think the printer thing is linked to network printers and also to the application keeping track of where every page ends etc. So there are a few other options to try below.

My VBA experience is limited to excel so I don't want to comment on your specific code but generally you should avoid Select / Selection if at all possible.

How about switching to Normal view before you run your code?

And wrap your code like this:

Application.ScreenUpdating = False
Application.PrintCommunication = False 'never tried this but could be similar to the printer thing.
Options.Pagination = false 'never tried this myself
[your code]
Application.ScreenUpdating = True
Application.PrintCommunication = true
Options.Pagination = True



Gavin