Attribute VB_Name = "ZapiszDoPdf_v19"
Const DEFAULT_FOLDER As String = "C:\Users\Paweł\Documents\PDF\" 'UWAGA NA POPRAWNĄ ŚCIEŻKĘ!
'-------------------------------------------------------------
Const KTH_EMAIL = "e@a.com"
Const KTH_VAT_ID = "IEXX1432589U"

'#########################################################
'# Paweł Grabowski 2018                                  #
'#                                                       #
'# Wymaga:                                               #
'# -> Outlook 2010+ ORAZ Word 2010+                      #
'# -> Biblioteka Microsoft word 14.0 Object Library !    #
'#                                                       #
'#########################################################

'zapis treci maila do pliku .pdf v1.91
Sub ConvertToPdfRaw()
    Call ConvertToPdf(CustomHeader:=False)
End Sub
Sub ConvertToPdfWithHeader()
    Call ConvertToPdf(CustomHeader:=True)
End Sub

Private Sub ConvertToPdf(Optional CustomHeader As Boolean = True)
    
    'Dim outApp As Object: Set outApp = CreateObject("Outlook.Application")
    Dim myItem As Outlook.MailItem
    Dim FolderPath As String: FolderPath = SetFolderPath
    
    For Each myItem In Application.ActiveExplorer.Selection
        On Error GoTo main_error_handler
        
        'tworzenie edytowalnej kopii obiektu myItem
        Dim cloneItem As Outlook.MailItem
        Set cloneItem = myItem.Forward 'CreateItem(0) 'olMailItem
        
        With cloneItem
            .Body = vbNullString
            If CustomHeader Then
                .HTMLBody = SetHtmlHeader(myItem)
            Else: .HTMLBody = myItem.HTMLBody
            End If
        End With
        
        ' deklaracja dla objInspector.WordEditor
        Dim objInspector As Object: Set objInspector = cloneItem.GetInspector
        Dim objDoc As Object: Set objDoc = objInspector.WordEditor
                     
        Dim FileName As String: FileName = SetFileName(myItem)
        Dim FilePath As String: FilePath = SetUniqueFilePath(FolderPath, FileName)
                
        'zapis do pliku (nr 17 = pdf) i oznaczenie kategorią
        objDoc.ExportAsFixedFormat FilePath, 17
        Call AddItemCategory(myItem, "Zapisane do .pdf")
                             
        Do Until Dir(FilePath) <> ""
            DoEvents ' opóźniacz na czas zapisywania pliku
        Loop
          
        cloneItem.Close olDiscard 'brak zapisu, zapobiega tworzeniu kopii roboczych
        Set objInspector = Nothing
        Set objDoc = Nothing
        Set cloneItem = Nothing
               
    Next myItem
    Exit Sub ' MUSI BYĆ POZA PĘTLĄ!!!

main_error_handler:
        MsgBox ("Wystąpił nieoczekiwany błąd w działaniu makra!")
        Set objInspector = Nothing
        Set objDoc = Nothing
        Set cloneItem = Nothing


End Sub

Private Function SetHtmlHeader(ByRef myItem As MailItem)
    Dim header As String

    If myItem.SenderEmailAddress = KTH_EMAIL Then
        header = "<table border=0>" _
        & "<tr><td width=""50%""><p>Numer:&nbsp;" & GetReservationNr(myItem) & "</p></td></tr>" _
        & "<tr><td><p>Data:&nbsp;" & Format(myItem.ReceivedTime, "Short Date") & "</p></td><td><p>Data otrzymania:&nbsp;" & myItem.ReceivedTime & "</p></td></tr>" _
        & "<tr><td><p>EU VAT NUMER:&nbsp;" & KTH_VAT_ID & "&nbsp;</p></td><td><p>Od:&nbsp;" & myItem.SenderEmailAddress & " do Exim S.A.</p></td></tr>" _
        & "</table>"
    Else
        header = "<p>" & "Data: " & myItem.ReceivedTime & "</p>" _
            & "<p>" & "Od: " & myItem.SenderEmailAddress & "</p>" _
            & "Temat: " & myItem.Subject
    End If
    
    SetHtmlHeader = header & "<hr>" & myItem.HTMLBody
End Function

 
Private Function GetReservationNr(ByRef myItem As MailItem) As String
    Dim txt As String: txt = myItem.Body
    Dim tag As String: tag = "Nr rezerwacji:"
    Dim posTag As Integer
    On Error GoTo error_handler
    posTag = InStr(1, txt, tag, vbTextCompare)
    txt = Mid(txt, posTag + 14 + 2, 6) 'dł+2 bo jeszcze nieusunięte CLRF
    txt = Replace(txt, Chr(10), vbNullString) 'Line Feed
    txt = Replace(txt, Chr(13), vbNullString) 'Carriage Return
    txt = Replace(txt, Chr(32), vbNullString) 'spacja
    txt = Replace(txt, Chr(160), vbNullString) 'twarda spacja
    GetReservationNr = txt
    Exit Function
    
error_handler: GetReservationNr = vbNullString

End Function

Private Function SetFolderPath() As String
    If DEFAULT_FOLDER <> "" Then
        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

Private Function SetFileName(ByRef myItem As MailItem) As String
    Dim sentOnDate As Date: sentOnDate = myItem.SentOn
    Dim FileName As String:
    If myItem.SenderEmailAddress = KTH_EMAIL Then
        FileName = "Ryanair " & GetReservationNr(myItem)
    Else
        FileName = ReplaceIllegalChars(myItem.Subject)
        'FileName = Replace(myItem.SenderEmailAddress & " " & sentOnDate, ":", "'")
    End If
    SetFileName = FileName
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: Debug.Print FilePath
    
    Do While Dir(FilePath) <> ""
        FilePath = FolderPath & FileName & "(" & i & ")" & ".pdf"
        i = i + 1
    Loop
    
    SetUniqueFilePath = FilePath
End Function
Private Sub SetItemCategory(myItem As MailItem, category As String)
    myItem.Categories = category '"Zapisane do .pdf"
    myItem.Save
End Sub

Private Sub AddItemCategory(myItem As MailItem, category As String)
    If InStr(1, myItem.Categories, category) = 0 Then
        myItem.Categories = myItem.Categories & ";" & category
        myItem.Save
    End If
End Sub

Sub OpenFolderPDF()
    If DEFAULT_FOLDER <> "" Then Call Shell("explorer.exe" & " " & DEFAULT_FOLDER, vbNormalFocus) Else MsgBox ("Brak zdefiniowanego folderu.")
End Sub

Private Function ReplaceIllegalChars(txt As String)

    Dim BadChar As String: BadChar = "\/:*?<>|[]"""
    Dim CharArray() As String
    
    BadChar = StrConv(BadChar, vbUnicode)
    CharArray = Split(BadChar, vbNullChar)
    
    For Each Char In CharArray
        txt = Replace(txt, Char, "")
    Next Char
    ReplaceIllegalChars = txt
End Function