Results 1 to 3 of 3

Thread: Macro (2000/)

  1. #1
    Star Lounger
    Join Date
    Oct 2001
    Location
    California
    Posts
    57
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Macro (2000/)

    I have a client that uses the word "Draft" as a watermark in her documents. She would like to know if a macro to create the watermark can be done... and could a macro be created to remove the watermark and/or to toggle the watermark off/on.

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: Macro (2000/)

    Yes it can be done but is a little problematic with documents that contain multiple sections because each section can contain up to three different sets of headers and footers. Along with that is a special oddity in the way the Word deals with floating objects in headers.

    Macros have been posted here in the past to install a watermark but they will only do it for the current section (unless there is a 'Same as Previous' running through) and the current page type (First Page, Left, Right or the related variants).

    The following is macro that will install the required watermark through the entire document. It has the drawback that to remove/replace the existing watermark the macro will remove any floating objects from the headers and footers. You will be presented with a couple of dialogs that will give you the functionality as requested. If you elect to NOT remove floating objects then a previous watermark will remain unless you manually remove them. If you do elect to remove the floating objects in the first dialog then the previous watermark will be removed. The second dialog can then be cancelled if you don't want any watermark or the text can be edited to provide whatever word you want to appear.

    <pre>Sub Watermarker()
    'Macro by Chrysalis Design 2001
    'Prompts the user to input the watermark text and then creates it
    Dim iResponse As Integer, aShape As Shape
    Dim sWarning As String, sWord As String, iCount As Integer

    On Error GoTo ErrCatcher
    With ActiveWindow
    If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
    .ActivePane.View.Type = wdNormalView
    End With
    'move to the Top of file
    Selection.HomeKey Unit:=wdStory

    ' Ask to remove all floating shapes from all headers/footers
    iResponse = MsgBox("Do you want to delete all floating objects from all Headers?" _
    & vbCr & vbCr & "This includes any existing Watermarks", _
    vbYesNoCancel, "Remove Floating Objects")
    If iResponse = vbYes Then
    'Note this actually deletes every floating object in every header
    'The definition says it only does it to one header - go figger!
    For Each aShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterP rimary).Shapes
    aShape.Delete
    Next aShape
    ElseIf iResponse = vbCancel Then
    Exit Sub
    End If

    'Gets user input to type the word to use as a watermark
    sWarning = "Please type in the word you want watermarked!" & vbCr & _
    "Click CANCEL to not add a Watermark"
    sWord = InputBox(sWarning, "Watermarker", "D R A F T")
    If sWord = "" Then Exit Sub 'If the user clicked cancel end the macro

    'Now creates the graphic which will be used as the watermark
    With ActiveWindow
    If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
    .ActivePane.View.Type = wdPageView
    .ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End With
    Selection.HeaderFooter.Shapes.AddTextEffect(msoTex tEffect13, sWord, _
    "Arial Black", 80#, msoFalse, msoFalse, 144.95, 139.1).Select
    With Selection.ShapeRange
    .Fill.ForeColor.RGB = RGB(180, 180, 180)
    .Fill.Visible = msoTrue
    .Fill.Solid
    .Shadow.Visible = msoFalse
    .IncrementRotation -30#
    If .Width > PointsToCentimeters(16) Then
    .Width = CentimetersToPoints(16)
    End If
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
    End With
    Selection.Copy 'stores this graphic in the clipboard
    'add a bookmark to indicate that a floater is here
    ActiveDocument.Bookmarks.Add Name:="zAnchor" & iCount, Range:=Selection.Range

    With ActiveWindow.ActivePane.View
    While Not False '(.NextHeaderFooter Is Nothing) 'doesn't work
    .NextHeaderFooter 'error 4605 if already in last header in doc
    iCount = iCount + 1
    If IncludesAnchor("zAnchor") = False Then
    'leave a bread crumb to mark the spot
    ActiveDocument.Bookmarks.Add Name:="zAnchor" & iCount, Range:=Selection.Range
    'stick in the graphic and centre on page
    Selection.Paste
    Selection.ShapeRange.Align msoAlignCenters, True
    Selection.ShapeRange.Align msoAlignMiddles, True
    End If
    Wend
    End With

    Exit Sub 'will never see this line unless error is avoided

    ErrCatcher:
    If Err.Number = 4605 Then 'caused by going forward from last header
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    ActiveWindow.ActivePane.View.Type = wdNormalView
    AnchorsAway ("zAnchor") 'clean away the bread crumbs
    Else
    MsgBox "There was an unexpected error. Please check the result" & vbCr & _
    vbCr & Err.Number & vbCr & Err.Description
    End If
    End Sub
    Function IncludesAnchor(sBk As String) As Boolean
    Dim aBookmark As Bookmark
    IncludesAnchor = False
    Selection.WholeStory
    For Each aBookmark In Selection.Bookmarks
    If Left(aBookmark.Name, 7) = sBk Then IncludesAnchor = True
    Next aBookmark
    Selection.Collapse Direction:=wdCollapseStart
    End Function
    Function AnchorsAway(sBk As String)
    Dim aBookmark As Bookmark
    For Each aBookmark In ActiveDocument.Bookmarks
    If Left(aBookmark.Name, 7) = sBk Then aBookmark.Delete
    Next aBookmark
    End Function</pre>

    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    Star Lounger
    Join Date
    Oct 2001
    Location
    California
    Posts
    57
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Macro (2000/)

    Thank you for responding so quickly! I will pass on the information to my client today! Have a great day!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •