Extract slide selection as presentation

' --------------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------

Option Explicit
Public Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Sub ExtractSelection()
    Dim oPres As Presentation
    Dim oSlide As Slide
    Dim sIDs As String
    Dim sTempFile As String
    Dim I As Integer

    On Error Resume Next
    ' Create a string containing slide IDs of selection
    ' It output string  will look like this ":256:276:290:"
    sIDs = ":"
    For Each oSlide In ActiveWindow.Selection.SlideRange
        sIDs = sIDs & CStr(oSlide.SlideID) & ":"
    Next oSlide
    ' Create path to store dummy file
    sTempFile = GetUserTempFolder & "~temp.ppt"
    ' save a copy of the original file
    Call ActivePresentation.SaveCopyAs(sTempFile)
    ' Open the copy
    Set oPres = Application.Presentations.Open(sTempFile, , False)
    ' Search for IDs which do not appear in the ID string and delete those slide.
    ' e.g. since it is a copy, it will also have the same slide IDs
    ' Search if ":256:" exists in the earlier list of IDs, if it does
    ' retain the slide else delete it.
    With oPres
        For I = .Slides.Count To 1 Step -1
            If InStr(1, sIDs, ":" & CStr(.Slides(I).SlideID) & ":") = 0 Then
                .Slides(I).Delete
            End If
        Next I
    End With
    oPres.Save
    oPres.Close
    Call Application.Presentations.Open(sTempFile, , True, True)
    ' Delete the temp file
    Kill sTempFile
End Sub

Function GetUserTempFolder() As String
    ' Function to retrieve the temp folder 
    On Error Resume Next
    Dim sTemp As String
    sTemp = String(100, Chr$(0))
    Call GetTempPath(100, sTemp)
    sTemp = Left(sTemp, InStr(sTemp, Chr$(0)) - 1)
    GetUserTempFolder = sTemp
    Exit Function
Error_GetUserTempFolder:
    GetUserTempFolder = ""
End Function

How to assign an interactive animation
 

We shall see how to create an interactive animation sequence. We shall create two shapes. Shape A will be assigned a circular motion path animation which will occur when the user clicks on Shape B.

This works for PowerPoint 2002 or later.

' --------------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------

Sub CreateAnimationWithTrigger()
    Dim oEffect As Effect
    Dim oShpA As Shape
    Dim oShpB As Shape
    With ActivePresentation.Slides(1)
	'Create two autoshapes on the slide.
        Set oShpA = .Shapes.AddShape(msoShapeRectangle, 100, 100, 50, 50)
        Set oShpB = .Shapes.AddShape(msoShapeRectangle, 200, 100, 50, 50)
	' Assign an interactive animation to shape A
        Set oEffect = .TimeLine.InteractiveSequences.Add _
                      .AddEffect(Shape:=oShpA, effectId:=msoAnimEffectPathCircle, _
                                 trigger:=msoAnimTriggerOnShapeClick)
    End With
    ' Define the triggering shape. If you omit this line then the animation will be 
    ' triggered by clicking on the shape A itself.
    oEffect.Timing.TriggerShape = oShpB
End Sub

Top