vba Excel 到 PowerPoint - 如果 ppt 已打开但特定的 pres 未打开，则打开特定的 pres，否则使用已经打开的 pres

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

提问by Jodders

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).

我正在 excel 中构建一个 VBA 宏，以将 excel 范围和 excel 图形复制到 PowerPoint 中。为此，我想打开一个现有的演示文稿 (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.

我想让代码做什么：查找 PowerPoint 是否打开；如果它是打开的然后检查pptName。如果 pptName 已经打开，则使用脚本进行，否则打开 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.

问题：我似乎无法让它使用已经打开的 pptName。它要么打开演示文稿的第二个新实例，要么使用最近使用的演示文稿，这通常不是我希望它编辑的特定演示文稿。

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

代码：将 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

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"

回答by Jodders

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

在这里，可能是一位用户有一天发现自己遇到了完全相同的问题并最终绊倒了这篇文章。那些说“我找到了解决方案”却忽略发布的人是多么残忍？！:-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

回答by Fabio

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

那么上面的代码需要一些编辑才能让它工作。或者使用此例程，您只需将 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: