Сохранить письмо Outlook в PDF

Код

Option Explicit

Public Const PDF_SAVE_PATH As String = "C:\MailPdf"

Public Function CleanFileName(ByVal text As String) As String
    Dim result As String
    Dim illegalChars As String
    Dim i As Long
    illegalChars = "/\:*?""<>|"
    result = Trim$(text)
    For i = 1 To Len(illegalChars)
        result = Replace(result, Mid$(illegalChars, i, 1), "_")
    Next i
    If Len(result) = 0 Then result = "letter"
    CleanFileName = result
End Function

Private Function JoinPath(ByVal folderPath As String, ByVal fileName As String) As String
    If Right$(folderPath, 1) = "\" Or Right$(folderPath, 1) = "/" Then
        JoinPath = folderPath & fileName
    Else
        JoinPath = folderPath & "\" & fileName
    End If
End Function

Private Function EnsureSaveFolder() As Boolean
    Dim fso As Object
    Dim pathNoSlash As String
    On Error GoTo Fail
    pathNoSlash = PDF_SAVE_PATH
    If Right$(pathNoSlash, 1) = "\" Or Right$(pathNoSlash, 1) = "/" Then
        pathNoSlash = Left$(pathNoSlash, Len(pathNoSlash) - 1)
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(pathNoSlash) Then fso.CreateFolder pathNoSlash
    EnsureSaveFolder = fso.FolderExists(pathNoSlash)
    Exit Function
Fail:
    EnsureSaveFolder = False
End Function

Private Sub WaitSeconds(ByVal seconds As Double)
    Dim t As Double
    t = Timer
    Do While Timer - t < seconds
        DoEvents
        If Timer < t Then t = Timer
    Loop
End Sub

Public Function SaveMailAsPdf(objMail As Outlook.MailItem, _
                              Optional ByVal showMessages As Boolean = True) As Boolean
    On Error GoTo ErrorHandler
    Dim objInspector As Outlook.Inspector
    Dim objDocument As Object
    Dim strFileName As String
    Dim fullPath As String
    Dim fileCounter As Long
    Dim stepName As String
    Dim fso As Object
    Dim exportAttempt As Long
    Dim exportOk As Boolean

    stepName = "Build file name"
    strFileName = Format(objMail.ReceivedTime, "yyyy-mm-dd") & "_" & _
                  CleanFileName(objMail.Subject) & ".pdf"
    If Len(strFileName) > 180 Then strFileName = Left$(strFileName, 176) & ".pdf"

    stepName = "Create folder"
    If Not EnsureSaveFolder() Then
        Err.Raise vbObjectError + 1, , "Cannot access/create folder: " & PDF_SAVE_PATH
    End If

    fullPath = JoinPath(PDF_SAVE_PATH, strFileName)
    Set fso = CreateObject("Scripting.FileSystemObject")
    fileCounter = 1
    Do While fso.FileExists(fullPath)
        fullPath = JoinPath(PDF_SAVE_PATH, Replace(strFileName, ".pdf", "_" & fileCounter & ".pdf"))
        fileCounter = fileCounter + 1
    Loop
    Set fso = Nothing

    stepName = "Open inspector"
    Set objInspector = objMail.GetInspector
    objInspector.Display
    DoEvents
    On Error Resume Next
    objInspector.WindowState = olNormal
    objInspector.Activate
    DoEvents
    On Error GoTo ErrorHandler

    stepName = "Get WordEditor"
    WaitSeconds 0.3
    Set objDocument = objInspector.WordEditor
    If objDocument Is Nothing Then Err.Raise 438, , "WordEditor is Nothing"

    stepName = "ExportAsFixedFormat"
    exportOk = False
    For exportAttempt = 1 To 3
        On Error Resume Next
        Err.Clear
        objDocument.ExportAsFixedFormat OutputFileName:=fullPath, ExportFormat:=17, OpenAfterExport:=False
        If Err.Number = 0 Then
            exportOk = True
            On Error GoTo ErrorHandler
            Exit For
        End If
        Err.Clear
        On Error GoTo ErrorHandler
        WaitSeconds 2
        objInspector.Activate
        Set objDocument = objInspector.WordEditor
    Next exportAttempt

    If Not exportOk Then Err.Raise vbObjectError + 2, , "ExportAsFixedFormat failed after 3 attempts"

    stepName = "Close inspector"
    objInspector.Close olDiscard
    WaitSeconds 0.4

    stepName = "Verify file"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(fullPath) Then
        If showMessages Then MsgBox "PDF created:" & vbCrLf & fullPath, vbInformation
        SaveMailAsPdf = True
    Else
        If showMessages Then MsgBox "File NOT created:" & vbCrLf & fullPath, vbCritical
        SaveMailAsPdf = False
    End If
    Exit Function

ErrorHandler:
    If showMessages Then
        MsgBox "ERROR: " & Err.Description & vbCrLf & "Step: " & stepName, vbCritical
    End If
    On Error Resume Next
    If Not objInspector Is Nothing Then objInspector.Close olDiscard
    SaveMailAsPdf = False
End Function

Связанные члены API

Inspector.Display Inspector.Close MailItem.GetInspector MailItem.SaveAs Inspector.WordEditor