CODEWITHSUNDEEP
vbaexcelpowerpoint
Daruki
Daruki

Reputation: 491

Save & Close powerpoint through Excel VBA

Below is code that creates multiple charts based on defined names, then opens powerpoint files with those defined names and dumps in the charts. I have everything working except the last part: save and close the file.

I've marked in green my attempts at trying to save and close the files. Any help is appreciated!

Sub Slide19()
Dim rngx As Range
Dim rngy As Range
Dim rngz As Range

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim icnt As Long
Dim lastrow As Long
Dim k As Long
Dim icounter As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Variant
Dim Chart As ChartObject
Dim PPapp As Object
Dim PPTDoc As PowerPoint.Presentation
Dim PPT As PowerPoint.Application
Dim PPpres As Object
Dim pptSlide As PowerPoint.Slide
Dim ppslide As Object

Dim filename As String
Dim filename2 As String

Set ws = Worksheets("Reference")
Set ws1 = Worksheets("Levels")
Set ws2 = Worksheets("Slide 19")

ws2.Activate
ws2.Range("e:f").NumberFormat = "0%"
lastrow = ws2.Cells(Rows.Count, "b").End(xlUp).Row
For icounter = 1 To lastrow
For icnt = 14 To 20
If ws2.Cells(icounter, 2) = ws.Cells(icnt, 3) Then

'd = ws.Cells(icnt, 3)
a = icounter + 1
b = icounter + 2
c = icounter + 12
filename = "filepath" & ws2.Cells(icounter, 2) & ".pptx"
filename2 = "xxyyxx" & ws2.Cells(icounter, 2)

'create RBI Vs LTM
Set rngx = Range(Cells(a, 4), Cells(c, 4))
        Set rngy = Range(Cells(a, 5), Cells(c, 6))

            ws2.Shapes.AddChart.Select
          ' ActiveChart.Name = ws2.Cells(icounter, 2) & "Slide8"
            ActiveChart.ChartType = xlColumnClustered
            ActiveChart.SetSourceData Source:=Union(rngx, rngy), PlotBy:=xlColumns

            With ActiveChart
            '.Name = d & "Slide8"
            .SetElement (msoElementChartTitleAboveChart)
            .ChartGroups(1).Overlap = 0
            .Legend.Delete
            .ChartTitle.Select
            .ChartTitle.Text = "Engagement by Level"
            .SeriesCollection(1).ApplyDataLabels
            .SeriesCollection(2).ApplyDataLabels

            .SeriesCollection(1).Interior.Color = RGB(0, 101, 179)
            .SeriesCollection(2).Interior.Color = RGB(192, 80, 77)
            .Axes(xlValue).MaximumScale = 1
           ' .Axes(xlValue).MinimumScale = 0.5
            '.Height = 374.4
            '.Width = 712.8

            .Axes(xlValue).TickLabels.NumberFormat = "0%"
            .SetElement (msoElementLegendRight)
            End With

            ActiveChart.Axes(xlValue).MajorGridlines.Select
            Selection.Format.Line.Visible = msoFalse
            ActiveChart.Legend.Select
            Selection.Left = 466.71
            Selection.Top = 12.467


            Set rngx = Nothing
            Set rngy = Nothing


With ActiveChart.Parent
.Height = Application.InchesToPoints(5.2)
.Width = Application.InchesToPoints(9.9)
End With

Set PPapp = CreateObject("Powerpoint.Application")

Set PPT = New PowerPoint.Application
PPT.Presentations.Open filename:=filename

PPapp.ActiveWindow.View.GotoSlide Index:=9


ActiveChart.ChartArea.Copy
PPapp.ActiveWindow.Panes(1).Activate
PPapp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
'PPT.ActivePresentation.SaveAs filename
'PPT.Presentations(filename2).Close
'PPapp.Quit


'PPT.Presentations.Close
End If
'PPapp.Quit
Next icnt
Next icounter
'PPapp.Quit



End Sub

Upvotes: 5

Views: 15252

Answers (2)

Kyle
Kyle

Reputation: 2545

I just tested the below which opens an instance of Powerpoint, makes it visible, creates a presentation, saves the presentation (path will need to be changed), quits the app and discharges the variable. Please let me know if this does not suit your needs.

Sub ppt()
Dim ppt As New PowerPoint.Application
Dim pres As PowerPoint.Presentation
ppt.Visible = True
Set pres = ppt.Presentations.Add
pres.SaveAs "C:\Users\xxx\Desktop\ppttest.pptx"
pres.Close
ppt.Quit
Set ppt = Nothing
End Sub

Upvotes: 5

Rufus
Rufus

Reputation: 378

Your code to save and close presentation should work properly. The only thing should be done is to put waiting function between saving and closing as closing line doesn't 'wait' for saving which is causing errors.

PPT.ActivePresentation.SaveAs filename
waiting(7) 'For my usage 7 seconds waiting is enough - it depends on size of your presentation
PPT.Presentations(filename2).Close

Function for waiting:

Sub waiting(tsecs As Single)
Dim sngsec As Single

sngsec = Timer + tsecs
Do While Timer < sngsec
    DoEvents
Loop

End Sub

And afterwards you can use:

PPT.Quit
set PPT = Nothing

Upvotes: 5

Related Questions