将Outlook电子邮件导出为PDF

Question

我必须将当天的Outlook电子邮件导出为PDF。

但是它仅将第一封电子邮件导出为PDF。 我也可以阅读主题，发件人姓名和日期。下面是代码。

代码中缺少一些内容。我已经使用了一些参考网址

https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/

Saving Outlook email as PDF + Attachments

Sub OutLook_Export()
On Error Resume Next
Dim O As Outlook.Application
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim FSO As Object, TmpFolder As Object
Dim sName As String
Set wrdApp = CreateObject("Word.Application")
Set O = New Outlook.Application

Dim ONS As Outlook.Namespace
Set ONS = O.GetNamespace("MAPI")

Dim MYFOLD As Outlook.Folder
Set MYFOLD = ONS.GetDefaultFolder(olFolderInbox)


Dim OMAIL As Object
Set OMAIL = O.CreateItem(olMailItem)

Dim R As Long
R = 2


For Each OMAIL In MYFOLD.Items

   J = Format(OMAIL.ReceivedTime, "MM/DD/YYYY")

   If J = Format(Date, "MM/DD/YYYY") Then

    Cells(R, 1).Value = OMAIL.ReceivedTime
    Cells(R, 2).Value = OMAIL.SenderEmailAddress
    Cells(R, 3).Value = OMAIL.Subject


    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpFileName = FSO.GetSpecialFolder(2)

    sName = OMAIL.Subject
    ReplaceCharsForFileName sName, "-"
    tmpFileName = tmpFileName & "\" & sName & ".mht"

    OMAIL.SaveAs tmpFileName, olMHTML


Set wrdDoc = wrdApp.Documents.Open(Filename:=tmpFileName, Visible:=True)

    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)

strToSaveAs = MyDocs & "\" & sName & ".pdf"

' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If

    wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs, ExportFormat:=wdExportFormatPDF, _
    OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
    Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
    wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
    CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
    BitmapMissingFonts:=True, UseISO19005_1:=False

    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing



    R = R + 1

    End If
Next OMAIL



End Sub



' This function removes invalid and other characters from file names
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
  sName = Replace(sName, "&", sChr)
  sName = Replace(sName, "%", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, " ", sChr)
  sName = Replace(sName, "{", sChr)
  sName = Replace(sName, "[", sChr)
  sName = Replace(sName, "]", sChr)
  sName = Replace(sName, "}", sChr)
  sName = Replace(sName, "!", sChr)
End Sub

任何反馈