Ошибка выполнения VBA: сохранить презентацию PowerPoint в формате PDF

Question

Я создаю презентацию Powerpoint из книги Excel (обе версии 2016 года) и в конце хочу сохранить презентацию в формате PDF.

Я пытался:

filenamePPT = Environ("UserProfile") & "\Desktop\" & Format(Date, "yyyy_mm_dd") & "_Statusbericht_" & ApName & "_KW" & KW & ".pdf"

ActivePresentation.ExportAsFixedFormat filenamePPT, ppFixedFormatTypePDF

и получение:

ошибка времени выполнения: -2147221165 (80040154): класс не зарегистрирован

во второй строке.

По-моему, я все сделал в соответствии с Документация Microsoft .

РЕДАКТИРОВАТЬ:

Все соответствующие ссылки добавляются:

• PowerPoint 16.0 Object Библиотека
• OLE Automation
• Библиотека объектов Office 16.0
• Библиотека объектов Forms 2.0
• Объекты данных ActiveX 6.1 Библиотека
• Объекты данных ActiveX Набор записей 6.0 Библиотека

РЕДАКТИРОВАТЬ2:

Public createslide6 As Boolean
Public ChartrngVONstring As String
Public ChartrngBISstring As String
Public filenameEXCEL As String
Public user As String


Sub VBA_AP_Status_v1()


Dim year As Double
Dim ZKW1 As Double
Dim ZKW2 As Double
Dim ZKW3 As Double
Dim ZKW4 As Double
Dim ZKW5 As Double
Dim ZKW6 As Double
Dim ZKW7 As Double
Dim ZKW8 As Double
Dim MS1Dauer As Double
Dim MS2Dauer As Double
Dim MS3Dauer As Double
Dim MS4Dauer As Double
Dim MS5Dauer As Double
Dim MS6Dauer As Double
Dim MS7Dauer As Double
Dim MS8Dauer As Double
Dim minScale As Double
Dim maxScale As Double
Dim e As Integer
Dim yearString As String
Dim nextyearString As String
Dim StandortVar As String
Dim filenamePPT As String
Dim pptLayout As CustomLayout

Dim AllgShape As Object
Dim MSShape As Object
Dim MSTShape As Object
Dim BemShape As Object
Dim APUShape As Object
Dim LGShape As Object
Dim HLShape As Object
Dim SlideNum As Object
Dim Fußzeile As Object
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide1 As Object
Dim mySlide2 As Object
Dim mySlide3 As Object
Dim mySlide4 As Object
Dim mySlide5 As Object
Dim mySlide6 As Object
Dim mySlide7 As Object
Dim myShape As Object
Dim ppTextbox As Object
Dim Chart1 As Object
Dim ChartLegend As Object
Dim MSPfeilLang As Object
Dim MSPfeilKurz As Object
Dim MSDreieck1 As Object
Dim MSDreieck2 As Object
Dim MSDreieck3 As Object
Dim MSDreieck4 As Object
Dim MSDreieck5 As Object
Dim MSDreieck6 As Object
Dim RisikenTable As Object



user = Environ("username")
year = Format(Date, "yyyy")
yearString = Format(Date, "yyyy")
nextyearString = Format(Date, "yyyy") + 1


'Create an Instance of PowerPoint
  On Error Resume Next

'Is PowerPoint already opened?
  Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
  Err.Clear

'If PowerPoint is not already open then open PowerPoint
  If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add


  myPresentation.ApplyTemplate "C:\Users\" & user & "\AppData\Roaming\Microsoft\Templates\Document Themes\AP_Status_Vorlage.thmx"


'Add slides to the Presentation
  Set mySlide1 = myPresentation.Slides.Add(1, ppLayoutCustom)       'an pos 1     '11 = ppLayoutTitleOnly
  Set mySlide2 = myPresentation.Slides.Add(2, ppLayoutTitleOnly)


  Set ppTextbox = mySlide1.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 80, 800, 80)




~ 2k lines of code were deleted here





filenameEXCEL = "C:\users\" & user & "\Desktop\Daten_Statusbericht_" & ApName & "_KW" & KW & "_" & Format(Date, "dd_mm_yy")
filenamePPT = Environ("UserProfile") & "\Desktop\" & Format(Date, "yyyy_mm_dd") & "_Statusbericht_" & ApName & "_KW" & KW & ".pdf"

'Make PowerPoint Visible and Active // OPTIONAL
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

'SAVING & CLOSING Powerpoint

  ActivePresentation.ExportAsFixedFormat filenamePPT, ppFixedFormatTypePDF

  'If Not GetObject(, "PowerPoint.Application") Is Nothing Then
    'GetObject(, "PowerPoint.Application").Quit
  'End If


'Call CloseAndSaveExcelApplication

End Sub

Есть предложения?

Answer 1

Dim PowerPointApp As Object

Dim myPresentation As Object

Dim mySlide1 As Object

Вы использовали позднюю привязку и раннюю привязку вместе. Попробуйте это

Option Explicit

Sub Sample()
    Dim oPPApp As PowerPoint.Application
    Dim oPPPrsn As PowerPoint.Presentation
    Dim oPPSlide As PowerPoint.Slide

    Dim FlName As String

    '~~> Change this to the relevant file
    FlName = "C:\Users\routs\Desktop\test.pdf"

    '~~> Establish an PowerPoint application object
    On Error Resume Next
    Set oPPApp = GetObject(, "PowerPoint.Application")

    If Err.Number <> 0 Then
        Set oPPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oPPApp.Visible = True

    '~~> Open the relevant powerpoint file
    Set oPPPrsn = oPPApp.Presentations.Add

    '~~> Change this to the relevant slide which has the shape
    Set oPPSlide = oPPPrsn.Slides.Add(1, ppLayoutCustom)

    oPPPrsn.ExportAsFixedFormat FlName, ppFixedFormatTypePDF
End Sub