Watermark macro

Have you tried recording a macro?
Each time that you insert a watermark, it automatically replaces the previous one, so all you have to do is to feed in your choice of wording.

I'll try it..

Didn't work.

The problem is, that I have lots of different documents. Some with one section some with more. And the macro is not stable. If I run it twice it give an error.

Zoodiaq: Have you seen this?
http://www.kiechle.com/oddsends/index.htm?wtrmrk/wtrmrk.htm

Yep been there...

Sorry to have given you such a simplistic answer. I have now researched it in more depth, and realise that the recorded macros are not accurate. In fact they can actually produce code with syntax errors.

However, even armed with that knowledge, I still cannot reproduce setting watermarks using VBA.

To inform you, and others, with progress so far, you should know:
1. There is no such thing as a watermark object.
2. Watermarks are implemented as semi-transparent shapes, anchored in each header.
3. There is one image per header type, (3 off) and one per section.
4. They are named "PowerPlusWaterMarkObject", followed by a number, starting at 1 up to sectioncount * 3

They seem to be created by the 'Shapes.AddTextEffect' method. Unfortunately, although there is an Anchor parameter, it seems so be ignored, so that all the shapes are anchored to Header1, Section1.

I am still reseaching, but welcome interventions.

The only progress that I have made so far is to find reports on the Internet that confirm that there is a bug in which the Anchor parameter does not work in the AddTextEffect method when used with Headers or Footers.

Sorry to have been so long.
A get-around is to Select the Header to which the Shape is to be Anchored.

Sub InsertWaterMarks(Doc As Document, strText As String)
    Dim sec As Section
    Dim hdr As HeaderFooter
    Dim sh As Shape
    Dim i As Integer
    Dim shHeaders As Shapes
   
    Set shHeaders = Doc.Sections(1).Headers(1).Shapes
   
    'Delete any existing watermarks
    For Each sh In shHeaders
        If InStr(sh.Name, "PowerPlusWaterMarkObject") = 1 Then
            sh.Delete
        End If
    Next sh
   
    'Add shape to headers shapes collection after selecting each header
    For Each sec In Doc.Sections
        For Each hdr In sec.Headers
            i = i + 1
            hdr.Range.Select
            Set sh = shHeaders.AddTextEffect(msoTextEffect1, _
                strText, "Times New Roman", 1, False, False, 0, 0)
            sh.Name = "PowerPlusWaterMarkObject" & i
            sh.TextEffect.NormalizedHeight = False
            sh.Line.Visible = False
            sh.Fill.Visible = True
            sh.Fill.Solid
            sh.Fill.ForeColor.RGB = RGB(128, 128, 128) - 25
            sh.Fill.Transparency = 0.75
            sh.Rotation = 315
            sh.LockAspectRatio = True
            sh.Height = CentimetersToPoints(6.88)
            sh.Width = CentimetersToPoints(13.77)
            sh.WrapFormat.AllowOverlap = True
            sh.WrapFormat.Side = wdWrapNone
            sh.WrapFormat.Type = 3
            sh.RelativeHorizontalPosition = _
                wdRelativeVerticalPositionMargin
            sh.RelativeVerticalPosition = _
                wdRelativeVerticalPositionMargin
            sh.Left = wdShapeCenter
            sh.Top = wdShapeCenter
        Next hdr
    Next sec
End Sub

Thank for the solution GrahamSkan. But I can't get it to work. I made a copy paste into word, macro. Put it doesn't run??? what did I do wrong. I can't see it in the list of macros.

It won't be in the list of macros, because it takes parameters.

I thought that you will be incorporating it in a a more complex procedure, otherwise it isn't any easier than using the macros.

However you could test it with this modified version.

Sub InsertWaterMarks2() 'Doc As Document, strText As String)
    Dim sec As Section
    Dim hdr As HeaderFooter
    Dim sh As Shape
    Dim i As Integer
    Dim shHeaders As Shapes
    Dim strText As String
    Dim Doc As Document
    Set Doc = ActiveDocument
    strText = InputBox("Please enter text", "Watermark")
    Set shHeaders = Doc.Sections(1).Headers(1).Shapes
   
    'Delete any existing watermarks
    For Each sh In shHeaders
        If InStr(sh.Name, "PowerPlusWaterMarkObject") = 1 Then
            sh.Delete
        End If
    Next sh
   
    'Add shape to headers shapes collection after selecting each header
    For Each sec In Doc.Sections
        For Each hdr In sec.Headers
            i = i + 1
            hdr.Range.Select
            Set sh = shHeaders.AddTextEffect(msoTextEffect1, _
                strText, "Times New Roman", 1, False, False, 0, 0)
            sh.Name = "PowerPlusWaterMarkObject" & i
            sh.TextEffect.NormalizedHeight = False
            sh.Line.Visible = False
            sh.Fill.Visible = True
            sh.Fill.Solid
            sh.Fill.ForeColor.RGB = RGB(128, 128, 128) - 25
            sh.Fill.Transparency = 0.75
            sh.Rotation = 315
            sh.LockAspectRatio = True
            sh.Height = CentimetersToPoints(6.88)
            sh.Width = CentimetersToPoints(13.77)
            sh.WrapFormat.AllowOverlap = True
            sh.WrapFormat.Side = wdWrapNone
            sh.WrapFormat.Type = 3
            sh.RelativeHorizontalPosition = _
                wdRelativeVerticalPositionMargin
            sh.RelativeVerticalPosition = _
                wdRelativeVerticalPositionMargin
            sh.Left = wdShapeCenter
            sh.Top = wdShapeCenter
        Next hdr
    Next sec
End Sub

Or alternatively you could call the original with another sub:

Sub CallWmMacro()
       InsertWaterMarks Activedocument, "My Watermark"
End Sub

Ok, I'm not that good with VB. But my goal is just to put the macro in a button. That shouldn't be to complicated.

It shouldn't be complicated, but it doesn't buy you much.

If you always want the same text, I suggest that you use the calling macro.

I'm building it for my office. And the secretaries has to use it. I want to make it easy for them.

I think the solution will work for me. My final version looks like this.

Sub InsertWaterMarks()
    Dim sec As Section
    Dim hdr As HeaderFooter
    Dim sh As Shape
    Dim i As Integer
    Dim shHeaders As Shapes
    Dim strText As String
    Dim Doc As Document
    Set Doc = ActiveDocument
    strText = "COPY"
    Set shHeaders = Doc.Sections(1).Headers(1).Shapes
   
    'Delete any existing watermarks
    For Each sh In shHeaders
        If InStr(sh.Name, "PowerPlusWaterMarkObject") = 1 Then
            sh.Delete
        End If
    Next sh
   
    'Add shape to headers shapes collection after selecting each header
    For Each sec In Doc.Sections
        For Each hdr In sec.Headers
            i = i + 1
            hdr.Range.Select
            Set sh = shHeaders.AddTextEffect(msoTextEffect1, _
                strText, "Arial", 1, False, False, 0, 0)
            sh.Name = "PowerPlusWaterMarkObject" & i
            sh.TextEffect.NormalizedHeight = False
            sh.Line.Visible = msoTrue
            sh.Line.Weight = 0.25
            sh.Line.DashStyle = msoLineSolid
            sh.Line.Style = msoLineSingle
            sh.Fill.Visible = msoFalse
            sh.Fill.Solid
            sh.Line.ForeColor.RGB = RGB(0, 0, 0)
            sh.Line.BackColor.RGB = RGB(255, 255, 255)
            sh.Fill.Transparency = 0#
            sh.Rotation = 315
            sh.LockAspectRatio = True
            sh.Height = CentimetersToPoints(6.88)
            sh.Width = CentimetersToPoints(13.77)
            sh.WrapFormat.AllowOverlap = True
            sh.WrapFormat.Side = wdWrapNone
            sh.WrapFormat.Type = 3
            sh.RelativeHorizontalPosition = _
                wdRelativeVerticalPositionMargin
            sh.RelativeVerticalPosition = _
                wdRelativeVerticalPositionMargin
            sh.Left = wdShapeCenter
            sh.Top = wdShapeCenter
        Next hdr
    Next sec
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        ActiveWindow.View.Type = wdPrintView
    End If
End Sub

However one probl. still occours. If I have a document with more than one section the watermark will be twice in section 2, three times in section 3 and so on. Now I'm not sure, because I have a bad printer at home, but my guess is, that that the watermark - if you use grayed tones - will look different in section 2 and 3 because there will be an overlap. However with the graphic I have choosen -which is just black - this shouldn't be a problem.

There is one prob. If the document is setup to have a "special first page" the macro has a glitch. That occours if you have the curser on the first page and then run the macro, it will not show the watermark on the others pages expcept page one. Could that issue be solved??

I can see problem 1. I don't know the cause yet, so I'm not sure if it's fixable. Testing for problem 2.

I assumed that LinkToPrevious was not set anywhere. This new code should avoid repeating the watermarks.
I can't reproduce the second problem with this code. Let me know if it is still there.

Sub InsertWaterMarks()
    Dim sec As Section
    Dim hdr As HeaderFooter
    Dim sh As Shape
    Dim i As Integer
    Dim shHeaders As Shapes
    Dim strText As String
    Dim Doc As Document
    Set Doc = ActiveDocument
    strText = "COPY"
    Set shHeaders = Doc.Sections(1).Headers(1).Shapes
   
    'Delete any existing watermarks
    For Each sh In shHeaders
        If InStr(sh.Name, "PowerPlusWaterMarkObject") = 1 Then
            sh.Delete
        End If
    Next sh
   
    'Add shape to headers shapes collection after selecting each header
    For Each sec In Doc.Sections
        For Each hdr In sec.Headers
            If sec.Index = 1 Or hdr.LinkToPrevious = False Then
                i = i + 1
                hdr.Range.Select
                Set sh = shHeaders.AddTextEffect(msoTextEffect1, _
                    strText, "Arial", 1, False, False, 0, 0)
                sh.Name = "PowerPlusWaterMarkObject" & i
                sh.TextEffect.NormalizedHeight = False
                sh.Line.Visible = msoTrue
                sh.Line.Weight = 0.25
                sh.Line.DashStyle = msoLineSolid
                sh.Line.Style = msoLineSingle
                sh.Fill.Visible = msoFalse
                sh.Fill.Solid
                sh.Line.ForeColor.RGB = RGB(0, 0, 0)
                sh.Line.BackColor.RGB = RGB(255, 255, 255)
                sh.Fill.Transparency = 0#
                sh.Rotation = 315
                sh.LockAspectRatio = True
                sh.Height = CentimetersToPoints(6.88)
                sh.Width = CentimetersToPoints(13.77)
                sh.WrapFormat.AllowOverlap = True
                sh.WrapFormat.Side = wdWrapNone
                sh.WrapFormat.Type = 3
                sh.RelativeHorizontalPosition = _
                    wdRelativeVerticalPositionMargin
                sh.RelativeVerticalPosition = _
                    wdRelativeVerticalPositionMargin
                sh.Left = wdShapeCenter
                sh.Top = wdShapeCenter
            End If
        Next hdr
    Next sec
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        ActiveWindow.View.Type = wdPrintView
    End If
End Sub

The watermark doesn't repeat itself now, so thats solved. However the second problem still occours.

I don't understand that, but I've put a line in to Select the whole document

It solves most of the problem. Only one instance isn't covered. Ill try to explain.

Do as followes:
Open af new doc in word. (Then it will of course only show one page)
Go to file the choose "Pagedocument setting" or "page settings" I'm not sure whats it's called in the english version.
Choose "Layout" and select "special first page" then choose ok
Now run the macro
Goto page 2 in the document. The Copy watermark doesn't show.

Of course I can just run it again... but it would be more nice if it just worked the first time no matter how you treat the document.

One solution could be to ask the macro to create a page to goto that page run the macro then delete the page again... But not sure that would be the right way to do it.

Zoodiaq,
I would never have guessed that you don’t work in English.
For your information, the settings are in File/PageSetup…, Layout tab and the checkbox caption is ‘Different first page’.

You will recall that I am selecting the target header because the Anchor parameter of the AddTextEffect method doesn’t work in Headers and Footers.

Unfortunately that means that if the page of a particular type (primary , first or even) doesn’t exist when the macro is run, it never gets selected and does not receive the watermark shape.

I think that the  macro will have to be re-run in those circumstances.

Nope, I use a Danish version :-)

Well, I'm sure you are right, that was also my conlusion. I'll leave it with what you have accomplished for me. Thanks for the work. It was great help...as usual.

Sorry to ask you, now the question is solved, but can you help me with a failsafe: I no docs are open, then exit macro.

I mean: If no documents are open, then exit macro.

That is simply:

If Documents.Count then
     Exit Sub
Endif

thx.

You are welcome. Thanks for the grade.