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