Excel到PowerPoint – 如果ppt打开但特定压力未打开，则打开特定压力，否则使用已打开的压力

我在Excel中build立一个VBAmacros，将Excel范围和Excelgraphics复制到PowerPoint中。 要做到这一点，我想打开一个现有的演示文稿（pptName）。

我很可能已经公开了演示文稿以及其他演示文稿。

我想要的代码：findPowerPoint是否打开; 如果打开，请检查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

所以我一直在努力，终于find了一个可行的解决scheme。

在这里，一个用户总有一天会遇到同样的问题，并最终绊倒这个岗位。 有多less残忍的人说“我find了解决scheme”，却忽视了发布呢？ 😀

这是我做的。 （在第一个代码中看到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: