Can't add unique TextEffect to each of the 3 headers Word2002007

[gmaxey]

Well, I can if I use a drawing canvas but that will cause a problem in Word2010. This code "seems" like it should work but all three watermarks are applied to the first page header. (The title should read Word 2003\2007

Option Explicit
Dim i As Long
Dim oShape As Shape
Dim pStr As String
Sub InsertTextEffect()
Dim oHdr As HeaderFooter
Dim oCanvas As Shape
Dim oRng As Word.Range
System.Cursor = wdCursorWait
For i = 1 To 3
Select Case i
Case 1
pStr = "Primary Hdr"
Case 2
pStr = "Even Pages Hdr"
Case 3
pStr = "First Page Hdr"
End Select
Set oHdr = Nothing
Set oHdr = ActiveDocument.Sections(1).Headers(i)
Set oRng = oHdr.Range
'Added for testing
oRng.Collapse wdCollapseEnd
Set oShape = oHdr.Shapes.AddTextEffect(msoTextEffect1, _
pStr, "Arial", 1, False, False, 0, 0, oRng)
With oShape
.Rotation = 0
.LockAspectRatio = True
.Height = 96
.RelativeHorizontalPosition = wdRelativeVerticalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = wdShapeCenter
.Top = wdShapeCenter
.Name = "Header Watermark " & i
.TextEffect.NormalizedHeight = False
End With
Next i
System.Cursor = wdCursorNormal
End Sub
Sub RemoveWaterMark()
On Error Resume Next
For i = 1 To 3
For Each oShape In ActiveDocument.Sections(1).Headers(i).Shapes
If InStr(oShape.Name, "Header Watermark") > 0 Then
oShape.Delete
End If
Next oShape
Next i
On Error GoTo 0
Application.ScreenRefresh
End Sub

[Janine]

Greg

I have resolved watermarks my own way with Custom Watermarks which works.


But I found this which explains what watermarks do - although this code does not work in Word 2010 it throws a lot of red lines.

'Have you had a play with watermarks in Word 2007 or 2010? It looks great – a nice little graphical drop down so you can see what you're inserting, the ability to create custom watermarks, what's not to like?

'For simple documents, this works really well. The problem is once you come to a document with multiple sections, or with different page headers.
'For example, set up a document with a few sections, and make sure the "Link To Previous" setting is off.
'Now go to any section, and insert a new watermark. See – it looks good.
'But now look at the other sections – they don't have the watermark.
'That's not too big a deal – so you then go to the other sections and add the watermark again.
'That looks good too, but now go look at the first section you put the watermark on, and it's gone!
'The process removes all watermarks from all other sections, and only inserts the watermark on the new section.
'Now this is getting dangerous when it comes to legal documents. You get the same issues when you use different first page footers within a section.

'It 's very easy to create your own custom code for inserting and deleting bookmarks, and even use the existing built-in bookmarks in 2007/2010.
'Turns out the bookmarks you see are just auto-text entries, and it's the name of the entries you see in the list.
'For example the Draft watermarks are auto-text entries "DRAFT 1" and "DRAFT 2".
'So you just need some code to insert the appropriate auto-text into the document, so look no further…

Sub InsertWatermark(ByVal WatermarkAutoTextName As String)
If Documents.Count > 0 Then
Application.ScreenUpdating = False
' Store the current location in document


ActiveDocument.Bookmarks.Add(Range:=Selection.Range,Name:="WatermarkTempBookmark")
' Load all building block templates
Templates.LoadBuildingBlocks()
' Find autotext entry first
Dim oTemplate As Template
Dim oAutoTextEntry As AutoTextEntry
Dim EntryFound As Boolean
Dim oSection As Section
Dim oRange As Range
EntryFound = False
For Each oTemplate In Templates
For Each oAutoTextEntry In oTemplate.AutoTextEntries
If LCase(oAutoTextEntry.Name) = LCase(WatermarkAutoTextName) Then
' Insert autotext in all headers in all sections of document
For Each oSection In ActiveDocument.Sections
oRange = oSection.Headers(wdHeaderFooterPrimary).Range
oRange.Collapse (wdCollapseStart)
oAutoTextEntry.Insert(rngRange, True)
oRange = oSection.Headers(wdHeaderFooterFirstPage).Range
oRange.Collapse (wdCollapseStart)
oAutoTextEntry.Insert(rngRange, True)
oRange = oSection.Headers(wdHeaderFooterEvenPages).Range
oRange.Collapse (wdCollapseStart)
oAutoTextEntry.Insert(rngRange, True)
Next oSection
EntryFound = True
Exit For
End If
Next oAutoTextEntry
If EntryFound Then Exit For
Next oTemplate
' Return to original place in document
If ActiveDocument.Bookmarks.Exists("WatermarkTempBookmark") Then
Selection.GoTo(What:=wdGoToBookmark, Name:="WatermarkTempBookmark")
ActiveDocument.Bookmarks("WatermarkTempBookmark").Delete()
End If
Application.ScreenUpdating = True
End If
End Sub
'Now just setup a sub to call the above with the appropriate autotext name, and add a button and callback to call this sub. As an example, the following sub will insert the first DRAFT watermark – "DRAFT 1".

Sub InsertDraftWatermark()
InsertWatermark ("DRAFT 1")
End Sub
'Now all you need is a routine to remove the watermarks. That's the easy part. All the watermarks inserted by the default autotexts contain "PowerPlusWaterMarkObject" in the name – so we just need to check the name of the shape objects throughout the document and delete them.

Sub RemoveWatermarks()
' Removes all Word 2010 watermarks
On Error Resume Next

If Documents.Count > 0 Then
Dim WatermarkShape As Shape
' Remove from body of document - the normal 2010 option inserts into the body
For Each WatermarkShape In ActiveDocument.Shapes
If InStr(1, WatermarkShape.Name, "PowerPlusWaterMarkObject", vbTextCompare) = 1 Then
WatermarkShape.Delete()
End If
Next
' Remove from headers
Dim oSection As Section
For Each oSection In ActiveDocument.Sections
For Each WatermarkShape In oSection.Headers(wdHeaderFooterPrimary).Shapes
If InStr(1, WatermarkShape.Name, "PowerPlusWaterMarkObject", vbTextCompare) = 1 Then
WatermarkShape.Delete()
End If
Next
For Each WatermarkShape In oSection.Headers(wdHeaderFooterFirstPage).Shapes
If InStr(1, WatermarkShape.Name, "PowerPlusWaterMarkObject", vbTextCompare) = 1 Then
WatermarkShape.Delete()
End If
Next
For Each WatermarkShape In oSection.Headers(wdHeaderFooterEvenPages).Shapes
If InStr(1, WatermarkShape.Name, "PowerPlusWaterMarkObject", vbTextCompare) = 1 Then
WatermarkShape.Delete()
End If
Next
Next oSection
End If
End Sub

[Janine]

Hi Greg
The main thing to note as Jay Freedman says Watermarks are "too smart".

To make things a little more interesting, Word doesn't load the
Building Blocks.dotx template into the Templates collection until the
user clicks the Insert > Quick Parts button or another button (such as
the Cover Page button or the Watermark button) that needs to show a
gallery of building blocks. The following macro uses the
LoadBuildingBlocks method to force the template to be loaded if it
isn't in the Templates collection yet.

Sub x()
Dim BBtemplate As Template, tmpTemplate As Template

' force loading of Building Blocks.dotx if it isn't present
Templates.LoadBuildingBlocks

' get Building Blocks as a template object
For Each tmpTemplate In Templates
If InStr(LCase(tmpTemplate.Name), "building blocks") Then
Set BBtemplate = tmpTemplate
Exit For
End If
Next

If Not BBtemplate Is Nothing Then
' now you can insert an entry from Building Blocks.dotx
Selection.EndKey Unit:=wdStory
Selection.MoveUp Unit:=wdScreen, Count:=1
BBtemplate.BuildingBlockEntries("SAMPLE 2").Insert _
Where:=Selection.Range, RichText:=True
End If
End Sub

The rest of your recorded code is suspicious, too. For one thing,
moving the Selection by Unit:=wdScreen isn't guaranteed to move it to
the page before the last page -- unless the last page contains less
than a screenful of text. And what constitutes a screenful depends on
the screen resolution of the particular computer and the zoom factor
of the current Word window, neither of which you've tried to control.

Another thing: unless you explicitly put the cursor (the Selection)
into a header pane, the "SAMPLE 2" building block is going to be
inserted as a floating Shape object in the main text, so it won't
appear on any other pages. This is a difference between the behavior
of building blocks inserted through the ribbon and those inserted by
code -- the Note in the VBA help topic "Working with Building Blocks"
says:

~~~
When you insert a building block by using the Ribbon, Word
automatically determines certain things about the building block, such
as where to insert it; however, when you insert a buildng block
through the object model, none of this built-in intelligence
automatically happens. For example, when you insert a header building
block by using the Ribbon, Word automatically determines to replace
the existing header. When inserting the same header building block by
using the object model, you need to explicitly specify where to place
the building block text.
~~~

Instead of moving the Selection, you would be better off determining
which of the document's sections should have the watermark, and then
inserting the building block into the correct header -- maybe
something like this:

Sub x2()
Dim BBtemplate As Template, tmpTemplate As Template
Dim numSecs As Long
Dim WMsec As Section, WMsecLast As Section

' force loading of Building Blocks.dotx if it isn't present
Templates.LoadBuildingBlocks

' get Building Blocks as a template object
For Each tmpTemplate In Templates
If InStr(LCase(tmpTemplate.Name), "building blocks") Then
Set BBtemplate = tmpTemplate
Exit For
End If
Next

If Not BBtemplate Is Nothing Then
' get next-to-last section
numSecs = ActiveDocument.Sections.Count
If numSecs > 1 Then
Set WMsec = ActiveDocument.Sections(numSecs - 1)
Else
Set WMsec = ActiveDocument.Sections.Last
End If
Set WMsecLast = ActiveDocument.Sections.Last

' turn off Same As Previous in both sections
WMsec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
WMsecLast.Headers(wdHeaderFooterPrimary).LinkToPrevious = _
False

' now you can insert an entry from Building Blocks.dotx
BBtemplate.BuildingBlockEntries("SAMPLE 2").Insert _
Where:=WMsec.Headers(wdHeaderFooterPrimary).Range, _
RichText:=True
End If
End Sub

[gmaxey]

Janine,

Thanks for you reply but I am not trying to insert watermarks that are defined as building blocks. I need to insert text watermarks that the user can create on the fly. I have done that, but my question is why won't the code (that I published above) that works in Word 2010 work in 2007/2003? Several years ago I wrote code to do the same thing in Word 2003/2007 which first adds a shape canvas (which apparently can be placed in each header story):

Option Explicit
Sub InsertWaterMark()
Dim oHdr As HeaderFooter
Dim oCanvas As Shape
Dim shpCanvas As Shape
Dim pStr As String
Dim oRng As Word.Range
Dim j As Long
Dim i As Long
System.Cursor = wdCursorWait
For j = 1 To ActiveDocument.Sections.Count
For i = 1 To 3
Select Case i
Case 1
pStr = "Primary Hdr"
Case 2
pStr = "First Page Hdr"
Case 3
pStr = "Even Page Hdr"
End Select
'On Error Resume Next
Set oHdr = Nothing
Set oHdr = ActiveDocument.Sections(j).Headers(i)
If oHdr.LinkToPrevious = False Then
Set oRng = oHdr.Range
oRng.Collapse wdCollapseEnd
Set oCanvas = oHdr.Shapes.AddCanvas(Left:=5, Top:=5, Width:=25, Height:=25, Anchor:=oRng)
With oCanvas
.RelativeHorizontalPosition = wdRelativeVerticalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = wdShapeCenter
.Top = wdShapeCenter
.Name = "Section " & j & " Header Watermark " & i
End With
Set shpCanvas = oCanvas.CanvasItems.AddTextEffect(msoTextEffect1, _
pStr, "Arial", 1, False, False, 0, 0)
With shpCanvas
.TextEffect.NormalizedHeight = False
.Rotation = 0
.LockAspectRatio = True
.Height = 72
End With
End If
Next i
Next j
System.Cursor = wdCursorNormal
End Sub
Sub RemoveWaterMark()
On Error Resume Next
Dim oSec As Section
Dim i As Long
Dim shpCanvas As Shape
For Each oSec In ActiveDocument.Sections
For i = 1 To 3
For Each shpCanvas In oSec.Headers(i).Shapes
If InStr(shpCanvas.Name, "Header Watermark") > 1 Then
shpCanvas.Delete
End If
Next shpCanvas
Next i
Next oSec
On Error GoTo 0
Application.ScreenRefresh
End Sub


This does exactly what I need it to do in Word2007/2003 but it causes a runtime error in Word2010. Right now I have both versions in my project and call as appropriate. I was looking of a way to have code that would work in all three versions and I am still stumped as to why the code I posted at the start of this threas won't work.

[Frosty]

For me, the code you posted for 2010 flat out doesn't work. There are dragons in the .Shapes collection of header/footer objects in 2003 (I've run into fairly major crash bugs when dealing with the shapes collection in 2003).

Maybe those crash bugs are gone in later versions, but there are still bugs when dealing with anchors and ranges.

This is, I believe, one of those areas where the use of the selection object is almost necessary (since using the anchor argument is simply not reliable).

Try this code out in both versions (tested in 2003 and 2010, not 2007 though). It's not elegant, because it relies on the selection object and seek view, but it does work.

Sub InsertTextEffectNew()
Dim hf As Word.HeaderFooter
Dim pStr As String
Dim rngOrigSelection As Range
Dim lView As Long

'store the current settings
Set rngOrigSelection = Selection.Range
lView = ActiveWindow.View
'stop looking at me!
'Application.ScreenUpdating = False
'required for the use of the seek view
ActiveWindow.View = wdPrintView
For Each hf In ActiveDocument.Sections(1).Headers
Select Case hf.index
Case wdHeaderFooterPrimary
pStr = "Primary Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekPrimaryHeader
On Error GoTo 0
Case wdHeaderFooterEvenPages
pStr = "Even Pages Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekEvenPagesHeader
On Error GoTo 0
Case wdHeaderFooterFirstPage
pStr = "First Page Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekFirstPageHeader
On Error GoTo 0
End Select
InsertTextEffectInHeader hf, pStr
Next
'restore the settings
rngOrigSelection.Select
ActiveWindow.View = lView
Application.ScreenUpdating = True
End Sub
Sub InsertTextEffectInHeader(hf As HeaderFooter, pStr As String)
Dim oShp As Word.Shape

With hf
'notice that using the commented out code, still causes the problem
'Set oShp = hf.Shapes.AddTextEffect(msoTextEffect1, _
pStr, "Arial", 1, False, False, 0, 0, hf.Range)
Set oShp = hf.Shapes.AddTextEffect(msoTextEffect1, _
pStr, "Arial", 1, False, False, 0, 0)
With oShp
.Rotation = 0
.LockAspectRatio = True
.Height = 96
.RelativeHorizontalPosition = wdRelativeVerticalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = wdShapeCenter
.Top = wdShapeCenter
'when setting the name of a shape (which must be unique)
'append a random number to it, to prevent naming problems
.name = "Header Watermark " & VBA.CStr(Round(1000 * Rnd(Timer), 0))
.TextEffect.NormalizedHeight = False
End With
End With
End Sub
Sub RemoveWaterMark()
Dim i As Long
Dim oShape As Shape
Dim pStr As String
On Error Resume Next
For i = 1 To 3
For Each oShape In ActiveDocument.Sections(1).Headers(i).Shapes
If InStr(oShape.name, "Header Watermark") > 0 Then
oShape.Delete
End If
Next oShape
Next i
On Error GoTo 0
Application.ScreenRefresh
End Sub

[Frosty]

Note: the above code will error out on a document which doesn't have Different First Page and Different Even/Odd Footers. This is something to trap for, but I didn't want to make it more complicated than it already is, and just wanted to do a proof of concept (since you'll need to deal with SameAsPrevious as well)

EDIT: I did put in the error trapping... however, that method only works in 2010. In 2003, the shapes are inserted anyway, if you don't have Different Firsgt Page and Different Even/Odd marked (in 2010, it inserts them in the right place, even without the seekview working).

Going to adjust the code slightly...

[Frosty]

This now works for both 2003 and 2010... but becomes even less elegant, since 2003 doesn't handle inserting shapes into a "hidden" (i.e., unused) headerfooter index, even though it exists.

Sub InsertTextEffectNew()
Dim hf As Word.HeaderFooter
Dim pStr As String
Dim rngOrigSelection As Range
Dim lView As Long
Dim bDifferentFirstPage As Boolean
Dim bDifferentOddEvenPages As Boolean
Dim oSec As Section

'just going to work on the first section for the moment
Set oSec = ActiveDocument.Sections(1)
'store the current settings
Set rngOrigSelection = Selection.Range
lView = ActiveWindow.View
'need to store this for 2003 purposes
With oSec.PageSetup
bDifferentFirstPage = .DifferentFirstPageHeaderFooter
bDifferentOddEvenPages = .OddAndEvenPagesHeaderFooter
.DifferentFirstPageHeaderFooter = True
.OddAndEvenPagesHeaderFooter = True
End With
'stop looking at me!
Application.ScreenUpdating = False
'required for the use of the seek view
ActiveWindow.View = wdPrintView
For Each hf In oSec.Headers
Select Case hf.Index
Case wdHeaderFooterPrimary
pStr = "Primary Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekPrimaryHeader
On Error GoTo 0
Case wdHeaderFooterEvenPages
pStr = "Even Pages Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekEvenPagesHeader
On Error GoTo 0
Case wdHeaderFooterFirstPage
pStr = "First Page Hdr"
On Error Resume Next
ActiveWindow.View.SeekView = wdSeekFirstPageHeader
On Error GoTo 0
End Select
InsertTextEffectInHeader hf, pStr
Next
'restore the settings
rngOrigSelection.Select
ActiveWindow.View = lView
With oSec.PageSetup
.DifferentFirstPageHeaderFooter = bDifferentFirstPage
.OddAndEvenPagesHeaderFooter = bDifferentOddEvenPages
End With
Application.ScreenUpdating = True
End Sub
I'm sure there are other ways of handling... but first order is to make it work, right? ;)

Hope this helps.

[gmaxey]

Jason,

Thanks. We've since exchanged a few private messages and I think we are on the same or close to the same page.