VBA сохраняет только каждую вторую открытую презентацию PowerPoint

Question

У меня есть 31 график в файле Excel, который необходимо экспортировать в отдельный файл PowerPoint, и последующие 31 презентация PowerPoint должны быть сохранены.

Запустив приведенный ниже код, все графики успешно экспортируются в отдельные презентации;однако только каждая вторая презентация (PowerPoint1, PowerPoint3, PowerPoint5 и т. д.) сохраняется в виде файла на моем компьютере.Есть идеи почему?

Примечание: переменная 'path' была определена ранее в коде, когда пользователю была предоставлена ​​возможность выбрать свой собственный путь.

Любые указания приветствуются.

Const ppLayoutBlank = 2
Const ppViewSlide = 1
Const ppFixedFormatTypePDF As Long = 2
Const ppPrintSelection As Long = 2
Option Explicit

Sub ExportChartstoPowerPoint()

'
' Code to allow user to choose path goes here
'

Dim chr
For Each chr In Sheets("My Excel File").ChartObjects
    Dim PPApp As Object
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Presentations.Add
    PPApp.ActiveWindow.ViewType = ppViewSlide
    PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
    PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
    chr.Select
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    PPApp.ActiveWindow.View.Paste
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Next chr
PPApp.Visible = True

Dim CurOpenPresentation As Object
Dim PPProgram As Object
Set PPProgram = GetObject(, "PowerPoint.Application")
For Each CurOpenPresentation In PPProgram.Presentations
      CurOpenPresentation.SaveAs path & "\" & CurOpenPresentation.FullName & ".pptx"
      Application.Wait (Now + #12:00:03 AM#) ' Wait 3 seconds to allow the computer time to save the file before it closes it
      CurOpenPresentation.Close
Next CurOpenPresentation


End Sub

Answer 1

Позвольте мне подробнее объяснить исходную проблему:

Допустим, у вас есть 30 открытых презентаций PowerPoint.Вы запускаете цикл For, чтобы перебирать все 30. На первой итерации ваш CurOpenPresentation (первый элемент в вашей коллекции из 30) - это PowerPoint1.Вы сохраняете его в месте и закрываете.

Теперь у вас есть коллекция 29 открытых презентаций PowerPoint , и ваш CurOpenPresentation теперь является PowerPoint2, поскольку PowerPoint1 больше не существует в области действия, поскольку вы ее закрыли.Теперь вы нажимаете на строку Next CurOpenPresentation и переходите от PowerPoint2 к PowerPoint3, не сохраняя PowerPoint2.

Вот почему вы экономите только 1, 3, 5 и т. Д. :)

Answer 2

У вас уже есть PPApp в качестве объекта приложения PowerPoint - продолжайте использовать его и уберите строки, определяющие PPProgram.

Также объявите и создайте экземпляр объекта для добавляемой презентации:

Dim PPPres as Object
Set PPPres = PPApp.Presentations.Add

После этого используйте PPPres для работы с презентацией

PPPres.Slides.Add PPPres.Slides.Count + 1, ppLayoutBlank
PPApp.ActiveWindow.View.GotoSlide PPPres.Slides.Count

Thisтакже означает, что цикл не нужен для сохранения и закрытия презентации

 PPPres.SaveAs path & "\" & PPPres.FullName & ".pptx"
 Application.Wait (Now + #12:00:03 AM#) ' Wait 3 seconds to allow the computer time to save the file before it closes it
 PPPres.Close

Также неплохо явно освободить эти объекты до End Sub:

Set PPPres = Nothing
Set PPApp = Nothing

Если вы хотитевсегда используйте CreateObject для каждой презентации, тогда код также должен Quit для приложения PowerPoint до , для которого установлено значение Nothing.Кроме того, код может проверять наличие PowerPoint, используя GetObject, и только если он не запущен, используйте CreateObject для его запуска.Вокруг есть множество примеров кода, которые показывают, как это сделать.