Excel to PowerPoint - Если ppt открыт, но конкретный прес не открыт, тогда откройте специальный прес, иначе используйте уже открытый прес

Question

Я создаю макрос VBA в Excel, чтобы скопировать диапазоны Excel и Excel в PowerPoint. Для этого я хочу открыть существующую презентацию (pptName).

Возможно, у меня уже может быть презентация открытой, а также коллекция других презентаций.

Что я хочу сделать: Найти, если PowerPoint открыт; если он открыт, проверьте на pptName. Если pptName уже открыт, то выполните скрипт, иначе откройте pptName.

Вопрос: Я не могу заставить его использовать уже открытое имя pptName. Либо он открывает второй новый экземпляр презентации, либо использует недавно использованную презентацию, которая обычно не является конкретной, которую я хочу изменить.

Код: Dim ppApp Как PowerPoint.Application Dim ppSlide Как 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 

Еще одна попытка, еще не так:

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" 

Answer 1

Так что я продолжал работать на то, чтобы и, наконец, нашли рабочее решение.

Здесь он, вероятно, будет тем, что один пользователь, который однажды найдет себя с той же проблемой и в конечном итоге наткнется на это сообщение. Как жестокие люди говорят: «Я нашел решение», но потом пренебрегаю публикацией! : -D

Вот что я сделал. (см. тумбы и т. д. в первом коде)

'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 

Answer 2

Ну, приведенный выше код нуждается в некотором редактировании, чтобы заставить его работать. Также можно использовать эту процедуру, нужно просто установить ppName и ppFullPath, чтобы указать на презентацию вы хотите загрузить

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: