How to repeat shape on every page INSIDE the word doc

I've attached 2 .docx (Word 16 for Windows)
(a) "Pic with Box in document.docx" - it has a semi-transparent blue rectangular shape + a .jpg picture.  With the .jpg image positioned BEHIND the rectangle (giving the impression that the image is not as pronounced)
(b) "Pic with Box anchored to Header.docx" - same as above except the rectangle is anchored to the header , and being a header it's repeated on every page


I want to have (a) except repeated in the exact same spot on every page  The problem with (b) is that being a header it doesn't allow me to more the image (in the document) BEHIND the shape (header)

How can I do that (cntrl-c + cntrl v is a pain as I have approx 300 pages and difficult to get in the exact same spot.)
Pic-with-Box-in-document.docx
Pic-with-Box-anchored-to-Header.docx
enduranceAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

GrahamSkanRetiredCommented:
It isn't clear why you don't have the picture that you want repeated on every page anchored in the header,
0
enduranceAuthor Commented:
I want the SHAPE repeated every page - however the picture will change each page
0
Shaun VermaakTechnical SpecialistCommented:
You can try a watermark (under the Design tab). That would repeat on each page and be behind text.
0
Exploring ASP.NET Core: Fundamentals

Learn to build web apps and services, IoT apps, and mobile backends by covering the fundamentals of ASP.NET Core and  exploring the core foundations for app libraries.

enduranceAuthor Commented:
Thanks, though I want the rectangle in front of the text/image and the watermark forces it to the back
0
Paul SauvéRetiredCommented:
i imagine you don't want the text over the box/image...

i put both the as a watermark & moved a bit to the left so that the page has nothing on it but text...
Pic-and-Box-watermark.docx
0
GrahamSkanRetiredCommented:
You can try this VBA macro
Sub CopyShape()
    Dim sh As Shape
    Dim rng As Range
    Dim p As Integer
    Set sh = ActiveDocument.Shapes(2)
    sh.Select
    Selection.Copy
    For p = 2 To ActiveDocument.Range.Information(wdActiveEndPageNumber)
        Selection.GoTo wdGoToPage, wdGoToAbsolute, p
        Selection.Paste
    Next p
End Sub

Open in new window

0
enduranceAuthor Commented:
Paul:  your.docx has the picture as part of the header and thus repeats the same image on every page -I need to have different images
0
Paul SauvéRetiredCommented:
right - just remove it from the header
Pic-and-Box-watermark.docx
0
enduranceAuthor Commented:
Paul: since the box is a watermark - it doesn't allow me to move the picture behind the (semi transparent) box
0
enduranceAuthor Commented:
Graham - that might work.  How do I find out what shape number my rectangle is in the real document?
0
GrahamSkanRetiredCommented:
I used trial and error, but here is a small macro:
Sub SelectedIndex()
Dim s As Integer
For s = 1 To ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(s).Select
    If MsgBox("Shape no. " & s & " selected." & vbCrLf & "Continue?", vbYesNo) = vbNo Then
        Exit Sub
    End If
Next s
End Sub

Open in new window

0
enduranceAuthor Commented:
I just realized that the rectangle was the last shape added, so was easy to find the index.  :-)
I ran the code on the real document and it copied the rectangle to the exact same location on each page with a few exceptions - I've attached the document, can you see why it didn't work for every page (e.g. page 8 or 20)
0
GrahamSkanRetiredCommented:
The process to add files in this forum can be confusing. You need to 'Attach File',  Browse for it, and then Upload it.
0
enduranceAuthor Commented:
Simply my mistake, I just forgot, here it is
test-doc-real.docx
0
enduranceAuthor Commented:
Any idea why it didn't copy to the same position on some pages?
0
GrahamSkanRetiredCommented:
Yes, but I haven't got a workaround yet. The pages where it misplaces the shape have a table at the top. The paste process seems to be avoiding the table vertically, and centralising the shape horizontally.
0
enduranceAuthor Commented:
Anyway to paste it to an absolute x,y coordinate?
0
GrahamSkanRetiredCommented:
I am still  working on this, though a some other matters used most of my time today.

There isn't a way of specifying an exact coordinate when pasting a shape. Instead a range in the text is used for the Anchor. My code uses the range for the whole page. Normally this is enough.

I am looking at for a  more precise way of defining the Anchor. Alternatively I am looking for a reliable way of modifying the offset from something such as the page edge or the page margin.
0
enduranceAuthor Commented:
thanks!
0
GrahamSkanRetiredCommented:
This is the code that I am trying now. It doesn't work. The Left and the Top properties of the misplaced shapes are the same as the others, so there is still  something that I don't understand.

Sub CopyRectangles()
    Dim sh As Shape
    Dim sh1 As Shape
    Dim rng As Range
    Dim p As Integer
    
    Set sh = GetRectangleOnPage(1)
    sh.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
    sh.RelativeVerticalPosition = wdRelativeVerticalPositionPage
    sh.Select
    Selection.Copy
    For p = 2 To ActiveDocument.Range.Information(wdActiveEndPageNumber)
        DoEvents
        
        Selection.GoTo wdGoToPage, wdGoToAbsolute, p
        Selection.Paste
        Set sh1 = GetRectangleOnPage(p)
        If p = 7 Then
            Stop
        End If
        Debug.Print "Page: " & p, sh1.Left, sh1.Top,
        sh1.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        sh1.RelativeVerticalPosition = wdRelativeVerticalPositionPage
        'sh1.Anchor.SetRange ActiveDocument.Bookmarks("\Page").Range.Start, ActiveDocument.Bookmarks("\Page").Range.Start
        sh1.Left = sh.Left
        sh1.Top = sh.Top
        Debug.Print "New: " & p, sh1.Left, sh1.Top
    
    Next p
End Sub

Function GetRectangleOnPage(p As Integer) As Shape
Dim sh As Shape
For Each sh In ActiveDocument.Shapes
    If sh.Anchor.Information(wdActiveEndPageNumber) = p Then
        If InStr(sh.Name, "Rectangle") Then
            Set GetRectangleOnPage = sh
            Exit Function
        End If
    End If
Next sh
End Function

Open in new window

0
GrahamSkanRetiredCommented:
What we are trying to do is quite unusual. The fact that the text runs right-to-left make it even more unusua. I suspect that testing could have overlooked this exact circumstance and we are therefore looking at a bug.

I have tried setting the top and left values in code, but they are already set to the required values in spite of the fact that the shape is in the wrong place, so that is ineffective.

I tried moving the Anchor so that it is not inside the table, but the Anchor.SetRange method does nothing.

After trying several more ploys, I can report some success by tweaking the left and top settings by the difference in the target and the actual positions, In the case of Page 7, I have based the amount to move on the width of the table. However that doesn't work for page 18, so I haven't found out yet what the rule is.
Here is the latest code
Sub CopyRectangle()
    Dim sh As Shape
    Dim sh1 As Shape
    Dim rng As Range
    Dim p As Integer
    Dim sngWidth As Single
    Dim cl As Cell
    Dim rw As Row
    Set sh = GetRectangleOnPage(1)
    sh.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
    sh.RelativeVerticalPosition = wdRelativeVerticalPositionPage
    sh.Select
    Selection.Copy
    For p = 2 To ActiveDocument.Range.Information(wdActiveEndPageNumber)
        DoEvents
        
        Selection.GoTo wdGoToPage, wdGoToAbsolute, p
        Selection.Paste
        Set sh1 = GetRectangleOnPage(p)
        If sh1.Anchor.Tables.Count > 0 Then
            Stop
            sngWidth = 0
            Set rw = sh1.Anchor.Tables(1).Rows.First
            For Each cl In rw.Cells
                sngWidth = sngWidth + cl.Width
            Next cl
            sh1.Left = sh.Left - sngWidth
            sh1.Top = sh.Top - CentimetersToPoints(2.7)

        End If
        'Debug.Print "Anchor2:"; sh1.Anchor.Start, sh1.Anchor.End
        Debug.Print "Page: " & p, "sh1.Left:"; sh1.Left, "sh1.Top"; sh1.Top,
    
    Next p
End Sub

Function GetRectangleOnPage(p As Integer) As Shape
Dim sh As Shape
For Each sh In ActiveDocument.Shapes
    If sh.Anchor.Information(wdActiveEndPageNumber) = p Then
        If InStr(sh.Name, "Rectangle") Then
            Set GetRectangleOnPage = sh
            Exit Function
        End If
    End If
Next sh
End Function

Open in new window

0
enduranceAuthor Commented:
thanks so much for the progress on this.
0
GrahamSkanRetiredCommented:
Different approach.
This version looks for the first paragraph that is completely on the page and is not in a table and uses that as the paste target, and hence the Anchor,
It works, but it's a bit slow, so I'll try to speed it up
Sub CopyRectangle()
    Dim sh As Shape
    Dim sh1 As Shape
    Dim rng As Range
    Dim p As Integer
    Dim q As Integer
    Dim sngWidth As Single
    Dim cl As Cell
    Dim rw As Row
    Dim para As Paragraph
    Dim tbl As Table
    Set sh = GetRectangleOnPage(1)
    sh.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
    sh.RelativeVerticalPosition = wdRelativeVerticalPositionPage
    sh.Select
    Selection.Copy
    For p = 2 To ActiveDocument.Range.Information(wdActiveEndPageNumber)
        DoEvents
        q = 1
        Debug.Print "Page: " & p,
        Selection.GoTo wdGoToPage, wdGoToAbsolute, p
        Set rng = ActiveDocument.Bookmarks("\Page").Range
        Debug.Print "start: " & rng.Start, "end: " & rng.End,
        For Each para In rng.Paragraphs
            If para.Range.Tables.Count = 0 Then
                If para.Range.Start >= rng.Start Then
                    Exit For
                End If
            End If
            q = q + 1
        Next para
        Debug.Print "para: " & q, "Start: " & para.Range.Start, "End: " & para.Range.End
        para.Range.Paste
        
        Set sh1 = GetRectangleOnPage(p)
        If sh1 Is Nothing Then
            Stop
        End If
    Next p
End Sub

Function GetRectangleOnPage(p As Integer) As Shape
Dim sh As Shape
For Each sh In ActiveDocument.Shapes
    If sh.Anchor.Information(wdActiveEndPageNumber) = p Then
        If InStr(sh.Name, "Rectangle") Then
            Set GetRectangleOnPage = sh
            Exit Function
        End If
    End If
Next sh
End Function
Function GetShapeOnPage(p As Integer) As Shape
Dim sh As Shape
For Each sh In ActiveDocument.Shapes
    If sh.Anchor.Information(wdActiveEndPageNumber) = p Then
        Set GetShapeOnPage = sh
        Exit Function
    End If
Next sh
End Function

Open in new window

0
GrahamSkanRetiredCommented:
This is basically the same code, but it has been cleaned up so that it is about four times faster.

Sub CopyRectangle()
    Dim sh As Shape
    Dim rng As Range
    Dim p As Integer
    Dim para As Paragraph
    
    Set sh = GetRectangleOnPage(1)
    sh.Select
    Selection.Copy
    For p = 2 To ActiveDocument.Range.Information(wdActiveEndPageNumber)
        DoEvents
        Selection.GoTo wdGoToPage, wdGoToAbsolute, p
        Set rng = ActiveDocument.Bookmarks("\Page").Range
        For Each para In rng.Paragraphs
            If para.Range.Tables.Count = 0 Then
                If para.Range.Start >= rng.Start Then
                    Exit For
                End If
            End If
        Next para
        para.Range.Paste
    Next p
End Sub

Function GetRectangleOnPage(p As Integer) As Shape
Dim sh As Shape
For Each sh In ActiveDocument.Shapes
    If sh.Anchor.Information(wdActiveEndPageNumber) = p Then
        If InStr(sh.Name, "Rectangle") Then
            Set GetRectangleOnPage = sh
            Exit Function
        End If
    End If
Next sh
End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
enduranceAuthor Commented:
Amazing, thanks SO much!!!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.