These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Control PowerPoint from Excel

The example macro below demonstrates how you can create a new PowerPoint presentation.

Note! Read and edit the example code before you try to execute it in your own project!

Sub CreateNewPowerPointPresentation()
' to test this code, paste it into an Excel module
' add a reference to the PowerPoint-library
' create a new folder named C:\Foldername or edit the filnames in the code
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim i As Integer, strString As String
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add(msoTrue) ' create a new presentation
    ' or open an existing presentation
    ' Set pptPres = pptApp.Presentations.Open("C:\Foldername\Filename.ppt")
    
    ' apply a slide template
    pptPres.ApplyTemplate "C:\Program Files\Office XP\Templates\Presentation Designs\Globe.pot"
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
    End With
    With pptSlide ' add contents to a slide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
        For i = 1 To 5 ' create slide text content
            strString = strString & "Item number #" & i & Chr(13)
        Next i
        strString = Left$(strString, Len(strString) - 1)
        .Shapes(2).TextFrame.TextRange.Text = strString ' add text content
    End With
    
    ThisWorkbook.Worksheets(1).Range("A3:D10").Copy ' copy an Excel range
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
        .Shapes(2).Delete ' remove the text box
        .Shapes.Paste
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 100
            .Width = 600
            .Height = 400
        End With
    End With
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
        .Shapes(2).Delete ' remove the text box
        .Shapes.PasteSpecial ppPasteBitmap
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 150
            .Width = 600
            '.Height = 250
        End With
    End With
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
        .Shapes(2).Delete ' remove the text box
        .Shapes.PasteSpecial ppPasteOLEObject
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 150
            .Width = 600
            '.Height = 250
        End With
    End With
    
    ThisWorkbook.Worksheets(1).ChartObjects(1).Copy ' copy an Excel chart item
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly) ' add a slide
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
        .Shapes.PasteSpecial ppPasteDefault
        With .Shapes(.Shapes.Count)
            .Left = 120
            .Top = 125.125
            .Width = 480
            .Height = 289.625
        End With
    End With
    
'    ThisWorkbook.Charts(1).ChartArea.Copy ' copy an Excel chart
'    With pptPres.Slides
'        Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly) ' add a slide
'    End With
'    With pptSlide
'        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' add a slide title
'        .Shapes.PasteSpecial ppPasteDefault
'        With .Shapes(.Shapes.Count)
'            .Left = 120
'            .Top = 125.125
'            .Width = 480
'            .Height = 289.625
'        End With
'    End With
    
    Application.CutCopyMode = False ' end cut/copy from Excel
    Set pptSlide = Nothing
    
    On Error Resume Next ' ignore errors
    Kill "C:\Foldername\MyNewPresentation.ppt"
    With pptPres
        .SaveAs "C:\Foldername\MyNewPresentation.ppt"
        '.Close ' close the presentation
    End With
    On Error GoTo 0 ' resume normal error handling
    Set pptPres = Nothing
    
    pptApp.Visible = True ' display the application
    'pptApp.Quit ' or close the PowerPoint application
    Set pptApp = Nothing
End Sub

Document last updated 2005-07-25 09:43:16