SherryO
04-20-2007, 11:00 AM
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:
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
Any help woudl be appreciated. Thank you!
http://www.vbaexpress.com/forum/showthread.php?t=2946
This is the code I'm using:
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
Any help woudl be appreciated. Thank you!