TPE

[e-mail]

---

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

Sub DeleteAllButListedSlides(sSlideString as String, sSaveAs as String)
' This sub will create a new copy of the current presentation then
' delete all but the listed slides
'
' sSlideString is a list of slide numbers, e.g.  "1, 2, 4, 9, 10, 11"    
' sSaveAs is the full path to the file you want to save new presentation to
'
' Because it uses Split, it only works in PPT 2000 or higher

    Dim x As Long
    Dim lSlideNumber As Long
    Dim rayKeep() As String
    Dim bKeeper As Boolean
    Dim oPres as Presentation

    ' kill the spaces in sSlideString, if any
    sSlideString = Replace(sSlideString, " ", "")

    ' split the string into an array
    rayKeep() = Split(sSlideString, ",")

    Set oPres = ActivePresentation.SaveAs(sSaveAs)

    With oPres
        For lSlideNumber = .Slides.Count To 1 Step -1
            For x = LBound(rayKeep) To UBound(rayKeep)
                If .Slides(lSlideNumber).SlideIndex = CLng(rayKeep(x)) Then
                    '.Slides(lSlideNumber).Delete
                    bKeeper = True
                End If
            Next

            If Not bKeeper Then
                .Slides(lSlideNumber).Delete
            End If
            bKeeper = False

        Next
    End With

    ' if you wish, close the presentation with oPres.Close

End Sub

---