endurance
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
(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
It isn't clear why you don't have the picture that you want repeated on every page anchored in the header,
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.
ASKER
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
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
ASKER
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
Pic-and-Box-watermark.docx
ASKER
Paul: since the box is a watermark - it doesn't allow me to move the picture behind the (semi transparent) box
ASKER
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
ASKER
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)
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.
ASKER
Simply my mistake, I just forgot, here it is
test-doc-real.docx
test-doc-real.docx
ASKER
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.
ASKER
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.
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.
ASKER
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
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.
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
ASKER
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
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Amazing, thanks SO much!!!