Change to late binding and end MS PP

[MarkCBB]

Hi there VBA pros,

I have received pieces of this code from a few places, including Mrexcel.com, and I have been able to thus far edit and adapted it to what I need.

However there are a few things I have not been able to figure out.
first, I want to change the code to late binding as it will be used on xl 2007, (I am writing the code in 2010).

The second thing I need to do, is at the bottom of the code, it closes the PP - Presentation but not the application it self. I tried pptApp.Close, but got an error.


Below is the code:

Sub CreateNewPowerPointPresentation2()
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
Dim Graphcount As Integer

Count = 0
i = 1
 
 Graphcount = Worksheets("Reason Code Metrics").ChartObjects.Count

 Set pptApp = CreateObject("PowerPoint.Application")
 Set pptPres = pptApp.Presentations.Add(msoTrue)

 Do While i <= Graphcount

ActiveSheet.ChartObjects(i).Activate

With ActiveChart
    .ChartArea.Select
    .ChartArea.Copy
End With
 With pptPres.Slides
 Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
 End With
 
 With pptSlide
    .Shapes(1).TextFrame.TextRange.Text = ActiveChart.ChartTitle.Text
    .Shapes.PasteSpecial ppPasteBitmap
 With .Shapes(.Shapes.Count)
    .Left = 1
    .Top = 100
    .Width = 100
    .Height = 430
 End With
 End With

 Application.CutCopyMode = False
 Set pptSlide = Nothing

 i = i + 1
 Loop

With pptApp
    .Visible = True
    .Activate
End With

Dim Master_wb As Workbook
Set Master_wb = ActiveWorkbook

Application.CutCopyMode = False

If Len(Dir(Application.DefaultFilePath & "\CSI PRESSENTATIONS", vbDirectory)) > 0 Then
Else
    MkDir Application.DefaultFilePath & "\CSI PRESSENTATIONS"
End If
pptPres.SaveAs Application.DefaultFilePath & "\CSI PRESSENTATIONS\CSI PP" & " - " & Format(Now, "YYYY-MM-DD") & ".pptx"
pptPres.Close

Master_wb.Activate
 On Error Resume Next
 On Error GoTo 0
 Set pptPres = Nothing
 Set pptApp = Nothing
End Sub

 

[RoryA]

You need to declare all your PP objects as just Object and you need to declare constants for any PP constants you use, like ppLayoutTitleOnly, or use the literal values (which you can get from the Object Browser).
Quit is the method you want to close PP down.

 

[Norie]

Quit instead of Close.

 

[MarkCBB]

HI there Guys,

thank you for the help, I have been able to do everything exepct for the shapes. I get an object does not exist error.

Sub CreateNewPowerPointPresentation2()
Application.ScreenUpdating = False

Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim i As Integer, strString As String
Dim Graphcount As Integer

Count = 0
i = 1
 
 Graphcount = Worksheets("Reason Code Metrics").ChartObjects.Count

 Set pptApp = CreateObject("PowerPoint.Application")
 Set pptPres = pptApp.Presentations.Add(msoTrue)
 Set pptSlide = pptPres.Slides
 Set pptShape = pptPres.pptSlide.Shapes ' Errors here
 
 Do While i <= Graphcount

ActiveSheet.ChartObjects(i).Activate

With ActiveChart
    .ChartArea.Select
    .ChartArea.Copy
End With
 With pptPres.Slides
 Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
 End With
 
 With pptSlide
    .Shapes(1).TextFrame.TextRange.Text = ActiveChart.ChartTitle.Text
    .Shapes.PasteSpecial ppPasteBitmap
 With .Shapes(.Shapes.Count)
    .Left = 1
    .Top = 100
    .Width = 100
    .Height = 430
 End With
 End With

 Application.CutCopyMode = False
 Set pptSlide = Nothing

 i = i + 1
 Loop

With pptApp
    .Visible = True
    .Activate
End With

Dim Master_wb As Workbook
Set Master_wb = ActiveWorkbook

Application.CutCopyMode = False

If Len(Dir(Application.DefaultFilePath & "\CSI PRESSENTATIONS", vbDirectory)) > 0 Then
Else
    MkDir Application.DefaultFilePath & "\CSI PRESSENTATIONS"
End If
pptPres.SaveAs Application.DefaultFilePath & "\CSI PRESSENTATIONS\CSI PP" & " - " & Format(Now, "YYYY-MM-DD") & ".pptx"
pptPres.Close
pptApp.Quit
Master_wb.Activate
 On Error Resume Next
 On Error GoTo 0
 Set pptPres = Nothing
 Set pptApp = Nothing
 Application.ScreenUpdating = True
End Sub

 

[RoryA]

Why have you changed the code structure?

 

[MarkCBB]

I remove the early binding and set the PP as objects, just trying to figure out how I set the shapes.

 

[MarkCBB]

ok, I got it, I removed the

 Set pptShape = pptPres.pptSlide.Shapes ' Errors here

and it worked, But i dont understand why.