Alle PowerPoint Dateien in PDF - aus Excel

Frage: Wie kann ich alle PowerPoint Dateien eines Ordners (optional mit Unterordner) in PDF umwandeln - das Ganze aus Excel? Funktioniert ab Office 2007 (mit installiertem Plugin "speichern unter PDF oder XPS") bzw. mit Office 2010.

Option Explicit
Private Const ppSaveAsPDF = 32
Dim blnPPT As Boolean
Dim blnTMP As Boolean
Dim objPP As Object
Public Sub Main()
    Dim strPath As String
    On Error GoTo Fin
    strPath = "C:\Temp\PPT\" ' adapt!!!!
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        SearchFiles strPath, "*.ppt*", False ' without subfolders
        'SearchFiles strPath, "*.ppt*", True ' with subfolders
    Else
        MsgBox "Application is not installed!"
    End If
Fin:
    If Not objPP Is Nothing Then
        If blnPPT = True Then
            objPP.Quit
            blnPPT = False
        End If
    End If
    Set objPP = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            blnPPT = True
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim objFolder As Object
    Dim objFile As Object
    Dim objPPT As Object
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            Set objPPT = objPP.Presentations.Open(objFile.Path)
            objPPT.SaveAs objFile.ParentFolder.Path & "\" & _
                Left(objFile.Name, InStrRev(objFile.Name, ".")) & "pdf", ppSaveAsPDF
            objPPT.Close
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...