Attribute VB_Name = "WordNaPdf_v11"
Private Const DEFAULT_FOLDER As String = "C:\Users\Paweł\Documents\PDF" 'UWAGA NA POPRAWNĄ ŚCIEŻKĘ!
'#########################################################
'# Paweł Grabowski 2019                                  #
'#                                                       #
'# Wymaga:                                               #
'# -> Outlook 2010+ ORAZ Word 2010+                      #
'# -> Biblioteka Microsoft Word 14.0 Object Library !    #
'#                                                       #
'#########################################################
'v1.1 - TYLKO TYLKO POJEDYNCZY MAIL, TYLKO FORMAT .DOCX

Sub ConvertWordToPdf()
    
    Dim myItem As MailItem
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer":  Set myItem = ActiveExplorer.Selection.Item(1)
        Case "Inspector": Set myItem = ActiveInspector.CurrentItem
        Case Else: MsgBox ("Nie rozpoznano obiektu")
    End Select
    
    Dim message As String:
    message = "Uwaga!" & vbNewLine & "Ze względów bezpieczeństwa makro należy uruchamiać tylko dla maili od zaufanych nadawców. " _
        & vbNewLine & vbNewLine & "Konwersja na format .pdf wiąże się z otwarciem w tle poszczególnych załączników i może potrwać kilka minut. " _
        & vbNewLine & vbNewLine & "Czy chcesz kontynuować?"
        
    If MsgBox(message, vbYesNo, "Konwersja załączników na .pdf - prośba o potwierdzenie") = vbYes Then
        Call CheckAttachments(myItem)
    End If
    
End Sub

Private Sub CheckAttachments(ByRef myItem As MailItem)
    'Dim wdApp As Word.Application: Set wdApp = New Word.Application
    Dim wdApp As Object: Set wdApp = CreateObject("Word.Application") ' LATE BINDING

    'Dim objDoc As Document
    Dim objDoc As Object: Set objDoc = CreateObject("Word.Document")
    Dim counter As Integer: counter = 0
    Dim omissions As Integer: omissions = 0
    
    For Each Item In myItem.Attachments
        If Right(Item.FileName, 5) = ".docx" Then
              
            Dim FolderPath As String: FolderPath = SetFolderPath
            Dim FileName As String: FileName = Item.FileName
            Dim TempFilePath As String: TempFilePath = SetUniqueTempPath(FolderPath, FileName, ".docx")
            
            Item.SaveAsFile TempFilePath
            Set objDoc = wdApp.Documents.Open(TempFilePath)
            
            On Error GoTo error_handler:
            Do Until wdApp.ActiveDocument.Name <> vbNullString ' tu pojawia się problem
                DoEvents ' opóźniacz na czas otwierania pliku
            Loop
                                       
            FileName = Replace(Item.FileName, ".docx", "")
            Dim FilePath As String: FilePath = SetUniqueFilePath(FolderPath, FileName)
            objDoc.ExportAsFixedFormat FilePath, 17 '(nr 17 = pdf)
            counter = counter + 1
            
            objDoc.Close: Kill TempFilePath
        Else
            omissions = omissions + 1
        End If
    Next Item
    
    Set objDoc = Nothing
    wdApp.Quit: Set wdApp = Nothing
    MsgBox "Zakończono. Poprawnie przekonwertowano: " & counter & " z " & myItem.Attachments.Count & " załączników." _
    & vbNewLine & "Znalezione i pominięte " & "załączniki w formacie innym niż .docx - " & omissions
    Exit Sub
    
error_handler:
    MsgBox "Wystąpił nieoczekiwany błąd"
    Set objDoc = Nothing
    wdApp.Quit: Set wdApp = Nothing
End Sub
Private Function SetUniqueTempPath(ByVal FolderPath As String, ByRef FileName As String, ByRef Extension As String) As String
    
    Dim FilePath As String: FilePath = FolderPath & FileName
    Dim i As Integer: i = 1
    
    Do While Dir(FilePath) <> ""
        FilePath = FolderPath & Replace(FileName, Extension, "") & "-" & i & Extension
        i = i + 1
    Loop
    
    SetUniqueTempPath = FilePath: Debug.Print FilePath
End Function

Private Function SetUniqueFilePath(ByVal FolderPath As String, ByRef FileName As String) As String
    
    Dim FilePath As String: FilePath = FolderPath & FileName & ".pdf"
    Dim i As Integer: i = 1
    
    Do While Dir(FilePath) <> ""
        FilePath = FolderPath & FileName & "-" & i & ".pdf"
        i = i + 1
    Loop
    
    SetUniqueFilePath = FilePath: Debug.Print FilePath
End Function

Private Function SetFolderPath() As String
    If DEFAULT_FOLDER <> "" Then
        If SHOW_FOLDER_PICKER = True Then FolderPath = SelectDownloadFolder _
            Else FolderPath = DEFAULT_FOLDER
        If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
        If Dir(FolderPath, vbDirectory) = vbNullString Then MsgBox "Folder nie istnieje!"
    Else
        FolderPath = "" '= Documents
    End If
    SetFolderPath = FolderPath
End Function