×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!
  • Students Click Here

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Jobs

watermark change takes minutes (Word XP)

watermark change takes minutes (Word XP)

watermark change takes minutes (Word XP)

(OP)
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:

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 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=...):

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 

RE: watermark change takes minutes (Word XP)

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

RE: watermark change takes minutes (Word XP)

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.

RE: watermark change takes minutes (Word XP)

(OP)
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

RE: watermark change takes minutes (Word XP)

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

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Tek-Tips forums is a member-only feature.

Click Here to join Tek-Tips and talk with other members! Already a Member? Login

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close