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
You can try following macro
Sub EachShapeAsNewPage()Dim s As Shape, sr As ShapeRange, sc As ShapeRangeDim w As Double, h As Double, i As IntegerActiveDocument.BeginCommandGroup ("shapes") Set sr = ActiveSelectionRange If sr.Shapes.Count = 0 Then MsgBox "Please make a selection" Exit Sub End If optimize = True For Each s In sr s.GetSize w, h s.Copy ActiveDocument.AddPagesEx 1, Round(h + 1, Precision), Round(w + 1, Precision) ActivePage.ActiveLayer.Paste ActivePage.FindShapes.All.CreateSelection Set sc = SelectionRange sc.AlignRangeToPageCenter cdrAlignVCenter Next soptimize = FalseActiveDocument.Pages(1).ActivateActiveWindow.ActiveView.ToFitPageActiveDocument.EndCommandGroupEnd Sub
Best regards
Mek