Excel to PowerPoint - 如果ppt打開但特定的pres不打開，則打開特定的pres，否則使用已打開的pres

Question

我在Excel中構建了一個VBA宏，用於將Excel範圍和Excel圖形複製到PowerPoint中。爲此，我想打開一個現有的演示文稿（pptName）。

我很可能已經打開了演示文稿，還有其他演示文稿的集合。

我想要的代碼： 查找PowerPoint是否打開;如果它打開，然後檢查pptName。如果pptName已經打開，則使用腳本繼續，否則打開pptName。

問題： 我似乎無法讓它使用已經打開的pptName。要麼打開演示文稿的第二個新實例，要麼使用最近使用的演示文稿，這通常不是我希望編輯的特定演示文稿。

代碼： 昏暗ppApp作爲PowerPoint.Application 昏暗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: