save_all_doc_ppt_to_pdf.docm.vba

' Run inside of a .docm file's vba.
Option Explicit
Const sDir = "C:\temp\PDF\"
Const TESTING = False

Sub SaveDocAsPdf(wApp As Word.Application, fso As Variant, filePath As String, exportPath As String)
    Dim wDoc As Word.Document
    Set wDoc = wApp.Documents.Open(filePath)
    wDoc.ExportAsFixedFormat OutputFileName:=exportPath, ExportFormat:=wdExportFormatPDF
    wDoc.Close False
End Sub
Sub SavePptAsPdf(wApp As PowerPoint.Application, fso As Variant, filePath As String, exportPath As String)
    Dim wPpt As PowerPoint.Presentation
    Set wPpt = wApp.Presentations.Open(filePath)
    wPpt.ExportAsFixedFormat path:=exportPath, FixedFormatType:=ppFixedFormatTypePDF, OutputType:=ppPrintOutputSlides
    wPpt.Close
End Sub

Sub Recurse(docApp As Word.Application, pptApp As PowerPoint.Application, fso, objFolder)
    Dim objFile, objSubFolder
    
    For Each objFile In objFolder.Files
        Dim ext As String: ext = LCase(fso.GetExtensionName(objFile.Name))
        Dim sBaseName As String: sBaseName = fso.getBaseName(objFile.path)
        Dim parDir As String: parDir = fso.GetParentFolderName(objFile.path)
        Dim first2Char As String: first2Char = LCase(Mid$(sBaseName, 1, 2))
        Dim first3Char As String: first3Char = LCase(Mid$(sBaseName, 1, 3))
        Dim isDoc As Boolean: isDoc = StrComp(ext, "doc", vbBinaryCompare) = 0
        Dim isDocx As Boolean: isDocx = StrComp(ext, "docx", vbBinaryCompare) = 0
        Dim isPpt As Boolean: isPpt = StrComp(ext, "ppt", vbBinaryCompare) = 0
        Dim isPptx As Boolean: isPptx = StrComp(ext, "pptx", vbBinaryCompare) = 0
        Dim isFixture As Boolean: isFixture = _
            StrComp(first2Char, "FA", vbBinaryCompare) = 0 _
            Or StrComp(first2Char, "FB", vbBinaryCompare) = 0 _
            Or StrComp(first2Char, "FC", vbBinaryCompare) = 0 _
            Or StrComp(first2Char, "FD", vbBinaryCompare) = 0
        
        ' Dim isPrototype As Boolean: isPrototype = InStr(1, parDir, "Prototype\", vbBinaryCompare)
            Dim isEasEpsEts As Boolean ' Special requirements
        isEasEpsEts = StrComp(first3Char, "eas") = 0
        isEasEpsEts = isEasEpsEts Or StrComp(first3Char, "eps") = 0
        isEasEpsEts = isEasEpsEts Or StrComp(first3Char, "ets") = 0
        
        Dim sFileName As String
        sFileName = fso.getBaseName(objFile) + ".PDF"
        
        Dim exportPath As String
        
        If TESTING Then
            exportPath = sDir + sFileName ' Save to some temporary folder.
        Else
            exportPath = parDir + "\" + sFileName ' Save to the folder this file is in
        End If
        
        Dim needsExporting As Boolean
        If (fso.FileExists(exportPath)) Then
          ' If the word document is newer than the PDF...
          needsExporting = objFile.DateLastModified > fso.getFile(exportPath).DateLastModified
        Else
            needsExporting = True
        End If
          
        Dim isRequired As Boolean: isRequired = isFixture Or isEasEpsEts ' Or isPrototype
        If isRequired And needsExporting And (isDoc Or isDocx) Then
            Debug.Print "Converting " + sBaseName
            SaveDocAsPdf docApp, fso, objFile.path, exportPath
        ElseIf isRequired And needsExporting And (isPpt Or isPptx) Then
            Debug.Print "Converting " + sBaseName
            SavePptAsPdf pptApp, fso, objFile.path, exportPath
        ElseIf isEasEpsEts And (isDoc Or isDocx Or isPpt Or isPptx) Then
            Debug.Print sBaseName + " is not newer than PDF."
        Else
            ' Debug.Print sBaseName + " is not a document to convert."
        End If
    Next

    For Each objSubFolder In objFolder.SubFolders
        Recurse docApp, pptApp, fso, objSubFolder
    Next
End Sub


Sub saveDirectoryAsPDFs()

    Dim docApp As Word.Application
    Dim pptApp As PowerPoint.Application
    Dim fso As Object                            ' Used to handle paths, filenames, etc.
    Set fso = CreateObject("Scripting.FileSystemObject")

    'Open Word if not running, otherwise select active instance
    On Error Resume Next
    Set docApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If docApp Is Nothing Then
        'Open Word
        Set docApp = CreateObject("Word.Application")
        docApp.Visible = False
    End If

    On Error Resume Next
    Set pptApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0
    If pptApp Is Nothing Then
        'Open Word
        Set pptApp = CreateObject("Powerpoint.Application")
        pptApp.Visible = True
    End If
    
    Dim dwgFolder As String: dwgFolder = "C:\temp\"
    Dim sFolderPaths() As String
    ' Sub Folders
    sFolderPaths = Split( _
        dwgFolder + "1," + _
        dwgFolder + "2," + _
        dwgFolder + "3," + _
        dwgFolder + "4", _
    ",")
    Dim i As Integer
    For i = 0 To UBound(sFolderPaths)
        Recurse docApp, pptApp, fso, fso.GetFolder(sFolderPaths(i))
    Next i

    ' docApp.Quit
    pptApp.Quit

End Sub

Private Sub CommandButton1_Click()
    saveDirectoryAsPDFs
End Sub