TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Option Explicit

Sub CreateCustomShowFromSelection()

    Dim x As Long
    Dim MySlideIDs() As Long
    Dim sShowName As String

    ' Did the user select some slides?  If not, quit:
    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "Please select one or more slides in the" _
                      & " SLIDE SORTER, then try again"
        Exit Sub
    End If

    With ActiveWindow.Selection.SlideRange
        ' add the SlideID of each slide in current
        ' selection to an array

        ' start with one member in the array
        ReDim MySlideIDs(1 To 1) As Long

        ' step BACKWARDS through selection, else
        ' the show will be in reverse order:
        For x = .Count To 1 Step -1
            MySlideIDs(UBound(MySlideIDs)) = .Item(x).SlideID
            Debug.Print .Item(x).Name
            ReDim Preserve MySlideIDs(1 To UBound(MySlideIDs) + 1)
        Next

    End With

    ' Get a name for the show
    sShowName = InputBox("Name for your custom show:", _
                            "Custom show name", "")

    ' Quit if blank
    If Len(sShowName) = 0 Then
        Exit Sub
    End If

    ' now create a custom show using the array
    With ActivePresentation.SlideShowSettings.NamedSlideShows
        ' delete the custom show if it already exists:
        On Error Resume Next
        .Item(sShowName).Delete
        On Error GoTo 0

        Call .Add(sShowName, MySlideIDs)

    End With

End Sub