Excel 到 PowerPoint - 如果 ppt 已打开但特定的演示文稿未打开，则打开特定的演示文稿，否则使用已经打开的演示文稿。

Question

我正在Excel中构建一个VBA宏，用于将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"

- odonja09

Answer 1

所以我一直在努力并最终找到了解决方案。

这里是解决方案，也许有一天会有一个用户遇到完全相同的问题，然后偶然发现这篇文章。那些说“我已经找到解决方案”但却不发布的人是多么残忍！:-D

这是我所做的（请参见第一段代码中的dims等）

 '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

- odonja09

---

基本上问题在于您正在迭代 Presentations 集合，寻找是否与 SomeFileName.PPTX 匹配的 .FullName，但它永远不会匹配，因为 .FullName 返回的是完整路径，而不仅仅是文件名。正如您发现的那样，.Name 返回名称（包括扩展名，因此无需将其附加到要进行比较的文件名）。 - Steve Rindsberg

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:

- Fabio