I have a macro i am working on that with take the shapes from a range and create pages from those shapes. I would like to get them to center to their respective pages but i seem to be stuck. Any help is appreciated. Thanks
Sub PageasShape()
Dim s As Shape, sr As ShapeRange Dim w As Double, h As Double Set sr = ActiveSelectionRange If sr.Shapes.Count = 0 Then MsgBox "Please make a selection" Exit Sub End If For Each s In sr ActiveDocument.AddPages (1) s.GetSize w, h ActivePage.SizeHeight = Round(h + 1, Precision) ActivePage.SizeWidth = Round(w + 1, Precision) ActiveDocument.ReferencePoint = srCenter
Next s ActiveDocument.Pages(1).Activate End Sub
This one is working for me in X7. Your undo and redo shortcut keys have to be set as cntrl+z, cntrl+shift+z (default) and letter "p" as center to page.
Keeps first page as original then puts each shape centered on its own page . Thanks to Shelby Moore
Sub SeperateToPages()
Dim s As Shape, sDuplicate As Shape
Dim sr As ShapeRange
Dim PageNext As Page
Set sr = ActiveSelectionRange
If sr.Count = 0 Then Set sr = ActivePage.Shapes.All
For Each s In sr.Shapes
Set PageNext = ActiveDocument.InsertPages(1, False, ActivePage.Index)
Set sDuplicate = s.Duplicate
sDuplicate.MoveToLayer PageNext.Layers(s.Layer.Name)
SendKeys "^(z)"
SendKeys "^+(z)"
SendKeys "(p)"
DoEvents
Next s
End Sub