Excel 到 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

这就是我所做的。 （参见第一个代码中的 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

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: