Solved: Call SaveAs Dialog for PPT from Excel

[SherryO]

Hi - I had this post two years ago which walked me through getting the SaveAs dialog box to show in Powerpoint. It's worked great, but now I'm stumped as how to use this when I've called Powerpoint from Excel. It only returns the Excel SaveAs.

http://www.vbaexpress.com/forum/showthread.php?t=2946

This is the code I'm using:
[vba]
Sub MakeSlide()
Dim PPApp As Object
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
On Error Resume Next
Set PPApp = GetObject(, "Powerpoint.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ErrHandler
Set PPApp = CreateObject("Powerpoint.Application")
With PPApp
.Visible = True
.Presentations.Add
End With
Else
On Error GoTo ErrHandler
End If

With PPApp.Presentations.Add
.Slides.Add Index:=1, Layout:=ppLayoutTitle
End With

Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideWidth = 720
.SlideHeight = 576
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
PPApp.ActiveWindow.ViewType = ppViewSlide
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.Selection.SlideRange.Shapes.SelectAll
PPApp.ActiveWindow.Selection.ShapeRange.Delete
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
MsgBox ("Don't forget to save your new PowerPoint slide.")
ErrHandler:
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
On Error GoTo 0
End Sub
[/vba]
Any help woudl be appreciated. Thank you!

[Andy Pope]

Does this work for you?

[vba] MsgBox ("Don't forget to save your new PowerPoint slide.")

PPApp.FileDialog(msoFileDialogSaveAs).Show
[/vba]

[SherryO]

Yes it does!! You're a peach! I don't suppose you would know how to quit Powerpoint? Neither of these is working for me. I get an activeX can't create the object...
PPApp.Application.Quit
PowerPoint.Application.Quit

Thank you!

[Andy Pope]

Try this revision to the routine.
As only one instance of PP can be open you can just createobject. This will either use the open intance or create a new instance.
The .Close will close the application once the PPApp is set to Nothing.

[vba]Sub MakeSlide()
Dim PPApp As Object
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

' On Error Resume Next
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ErrHandler
With PPApp
.Visible = True
' not require as it causes 2 presentations
'''' .Presentations.Add
End With
Else
On Error GoTo ErrHandler
End If

With PPApp.Presentations.Add
.Slides.Add Index:=1, Layout:=ppLayoutTitle
End With

Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideWidth = 720
.SlideHeight = 576
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
PPApp.ActiveWindow.ViewType = ppViewSlide
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.Selection.SlideRange.Shapes.SelectAll
PPApp.ActiveWindow.Selection.ShapeRange.Delete
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
MsgBox ("Don't forget to save your new PowerPoint slide.")

PPPres.Close
PPApp.Quit

ErrHandler:
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
On Error GoTo 0
End Sub
[/vba]

[SherryO]

I cannot thank you enough. This works perfectly!!! Sherry