Excel to PowerPoint - If ppt is open but specific pres is not open, then open specific pres, else use already open pres

3
votes

I am building a VBA Macro in excel to copy excel ranges and excel graphs into PowerPoint. To do this I want to open an existing presentation (pptName).

It's very possible that I may already have the presentation open, along with a collection of other presentations.

What I want the Code To Do: Find if PowerPoint is open; if it's open then check for pptName. If pptName is already open then progress with script, otherwise open pptName.

Issue: I can't seem to get it to use the already open pptName. Either it opens a second new instance of the presentation, or it uses the most recently used presentation, which is usually not the specific one I want it to edit.

Code: Dim ppApp As PowerPoint.Application Dim ppSlide As PowerPoint.Slide

Dim pptName As String
Dim CurrentlyOpenPresentation As Presentation

pptName = "MonthlyPerformanceReport"

 'Look for existing instance
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

 'Create new instance if no instance exists
If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application

 'Add a presentation if none exists
 'If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add

 'If ppt is open, check for pptName. If pptName is already open then progress, otherwise open pptName
If ppApp.Presentations.Count > 0 Then
    For Each CurrentlyOpenPresentation In ppApp.Presentations
        If CurrentlyOpenPresentation.FullName = pptName & ".pptx" Then GoTo ProgressWithScript
    Next CurrentlyOpenPresentation
    ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptx"
End If
ProgressWithScript:

 'Open Presentation specified by pptName variable
If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptx"
'If ppApp.Presentations.Count > 0 Then ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptx"
'Application.DisplayAlerts = False

Another Attempt, still not right:

If ppApp.Presentations.Count > 0 _
Then
    For Each CurrentlyOpenPresentation In ppApp.Presentations
        If CurrentlyOpenPresentation.FullName = pptName _
        Then IsOpen = True

        If CurrentlyOpenPresentation.FullName = pptName _
        Then ppApp.ActiveWindow.View.GotoSlide ppApp.Presentations(pptName).Slides.Count

        If IsOpen = True Then GoTo ProgressWithScript

    Next CurrentlyOpenPresentation

'Else: ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptm"
End If

IsOpen = False

If IsOpen = False _
Then ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptm"
2
vbaexcelpowerpoint

2 Answers

3
votes

So I kept working at to and finally found a working solution.

Here it is for what will probably be that one user who one day find themselves with exactly the same problem and ends up stumbling upon this post. How cruel people are who say "I've found the solution" but then neglect to post it?! :-D

Here's what I did. (see dims etc.. in the first code)

 'Look for existing instance
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

 'Create new instance if no instance exists
If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application

 'If ppt is already open, check if the presentation (pptName) is open
 'If pptName is already open then Activate pptName Window and progress,
 'Else open pptName

If ppApp.Presentations.Count > 0 _
Then
    For Each CurrentlyOpenPresentation In ppApp.Presentations
        If CurrentlyOpenPresentation.Name = pptNameFull _
        Then IsOpen = True

        If IsOpen = True _
        Then ppApp.ActiveWindow.View.GotoSlide ppApp.Presentations(pptName).Slides.Count

        If IsOpen = True Then GoTo ProgressWithScript

    Next CurrentlyOpenPresentation

'Else: ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptName & ".pptm"
End If

IsOpen = False

If IsOpen = False _
Then ppApp.Presentations.Open Filename:=SheetLocation & "\" & pptNameFull
2
votes

Well the above code needs some editing to get it to work. Alternatively use this routine, you just need to set ppName and ppFullPath to point to the presentation you want to load

Dim ppProgram As PowerPoint.Application
Dim ppPitch As PowerPoint.Presentation

On Error Resume Next
Set ppProgram = GetObject(, "PowerPoint.Application")
On Error GoTo 0

If ppProgram Is Nothing Then
Set ppProgram = New PowerPoint.Application

Else
    If ppProgram.Presentations.Count > 0 Then
        ppName = Mid(ppFullPath, InStrRev(ppFullPath, "\") + 1, Len(ppFullPath))
        i = 1
        ppCount = ppProgram.Presentations.Count
        Do Until i = ppCount + 1
                If ppProgram.Presentations.Item(i).Name = ppName Then
                Set ppPitch = ppProgram.Presentations.Item(i)
                GoTo FileFound
                Else
                i = i + 1
                End If
        Loop
    End If
End If

ppProgram.Presentations.Open ppFullPath
Set ppPitch = ppProgram.Presentations.Item(1)

FileFound: