Sub SetPageSameAsSelected()
Dim sr As ShapeRange, s As Shape
Dim x#, y#, w#, h#
ActiveDocument.BeginCommandGroup ("pagesize")
ActiveDocument.Unit = cdrMillimeter
Set sr = ActiveSelectionRange
If sr.Count = 0 Then Exit Sub
sr.GetBoundingBox x, y, w, h
ActivePage.SetSize w + 5, h + 5
sr.AlignRangeToPageCenter (cdrAlignVCenter)
ActiveDocument.EndCommandGroup
End Sub

 Sub MySave()
    ' Recorded 1/27/2025
    Dim s As Shape, sr As ShapeRange
    Dim i As Long, strName As String
    Dim p As Page
    
    
    
    Dim SaveOptions As StructSaveAsOptions
    Set SaveOptions = CreateStructSaveAsOptions
    With SaveOptions
        .EmbedVBAProject = True
        .Filter = cdrAutoSense
        .IncludeCMXData = False
        .Range = cdrSelection
        .EmbedICCProfile = True
        .Version = cdrVersion15
        .KeepAppearance = True
    End With
    
    EventsEnabled = False
    i = 1
    For Each p In ActiveDocument.Pages
        p.Activate
        Set sr = ActivePage.Shapes.All
        For Each s In sr
            s.CreateSelection
            strName = "MySave_" & i
            ActiveDocument.SaveAs "C:\Users\KHTMfile\Documents\" & strName & ".cdr", SaveOptions
            i = i + 1
        Next s
    Next p
    eventsenable = True
End Sub