首页 文章

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

提问于
浏览 次
2

我正在excel中构建一个VBA宏来将excel范围和excel图表复制到PowerPoint中 . 为此，我想打开一个现有的演示文稿（pptName） .

我很可能已经开放了演示文稿，还有一些其他演示文稿 .

我想要代码做什么：查找PowerPoint是否开放;如果它打开然后检查pptName . 如果pptName已经打开，则使用脚本进行，否则打开pptName .

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

代码：Dim ppApp As PowerPoint.Application Dim ppSlide As 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"
excel vba excel-vba powerpoint powerpoint-vba

2 回答

  • 3

    所以我一直努力，最终找到了一个有效的解决方案 .

    这就是为什么有一天会发现自己遇到完全相同的问题并最终在这篇文章上磕磕绊绊的用户 . 多么残酷的人谁说“我找到了解决方案”，但后来忽略发布它？！ :-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
    回复于
  • 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:
    回复于

相关问题