KHTMFile 💾

Sub shapes_to_pages()
Dim s As Shape
Dim pThis As Page
Dim blnHaveCommandGroup As Boolean

    On Error GoTo ErrHandler
    
    If Not ActiveDocument Is Nothing Then
        If ActiveSelectionRange.Count > 0 Then
            EventsEnabled = False
            Optimization = True
            blnHaveCommandGroup = True
            ActiveDocument.BeginCommandGroup "shapes to pages"
            
            For Each s In ActiveSelectionRange
                Set pThis = ActiveDocument.AddPages(1)
                s.MoveToLayer pThis.Layers("Layer 1")
                s.CenterX = pThis.CenterX
                s.CenterY = pThis.CenterY
                pThis.SizeHeight = s.SizeHeight
                pThis.SizeWidth = s.SizeWidth
            Next s
            
        Else
            MsgBox "Nothing is selected."
        End If
    Else
        MsgBox "No document is active."
    End If

ExitSub:
    If blnHaveCommandGroup Then
        ActiveDocument.EndCommandGroup
        Optimization = False
        EventsEnabled = True
        Refresh
    End If
    Exit Sub

ErrHandler:
    MsgBox "Error occurred: " & Err.Description & vbCrLf & vbCrLf & "shapes_to_pages()"
    Resume ExitSub
End Sub