Link to home
Start Free TrialLog in
Avatar of endurance
enduranceFlag for United States of America

asked on

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
Avatar of GrahamSkan
GrahamSkan
Flag of United Kingdom of Great Britain and Northern Ireland image

It isn't clear why you don't have the picture that you want repeated on every page anchored in the header,
Avatar of endurance

ASKER

I want the SHAPE repeated every page - however the picture will change each page
You can try a watermark (under the Design tab). That would repeat on each page and be behind text.
Thanks, though I want the rectangle in front of the text/image and the watermark forces it to the back
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
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

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
right - just remove it from the header
Pic-and-Box-watermark.docx
Paul: since the box is a watermark - it doesn't allow me to move the picture behind the (semi transparent) box
Graham - that might work.  How do I find out what shape number my rectangle is in the real document?
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

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)
The process to add files in this forum can be confusing. You need to 'Attach File',  Browse for it, and then Upload it.
Simply my mistake, I just forgot, here it is
test-doc-real.docx
Any idea why it didn't copy to the same position on some pages?
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.
Anyway to paste it to an absolute x,y coordinate?
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.
thanks!
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

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

thanks so much for the progress on this.
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

ASKER CERTIFIED SOLUTION
Avatar of GrahamSkan
GrahamSkan
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Amazing, thanks SO much!!!