Control PowerPoint from Excel
2005-07-25 Import & Export 0 316
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