使用 header 使用 WordEditor 将邮件保存为 pdf

Question

我想保存邮件 body 和 header 就像它是由 Outlook 或 PDFCreator 打印的一样。发件人、抄送、密件抄送、时间、收件人、主题是pdf中必须有的数据。

使用这个 post 和其他：

我对这个宏进行了编码：

在 Outlook 中获取选定的邮件
在硬编码文件夹中创建一个新文件夹
使用 WordEditor 将邮件 body 打印为 PDF

WordEditor object 不保存邮件项的 HEADER。对我来说，重要的是要知道是谁发的，什么时候发的，e-mail地址，主题等等

我想知道如何从 WordEditor object 添加 header。

Option Explicit

Sub mail_to_pdf_sof()
    Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object, coll As Object, Sel As Object, objInspector As Object, objDoc As Object
    Dim psName As String, pdfName As String, strFolderpath As String, Path As String, time_record As String, FileName As String
    Dim rol As Integer, indice As Integer, i As Integer
    
    Set outApp = CreateObject("Outlook.Application")
    Set objOutlook = outApp.GetNamespace("MAPI")
    
    ' PATH TO SAVE PDFs
    Path = "F:\"
    Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
    
    On Error Resume Next
    MkDir Path
    On Error GoTo 0
 
    ' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF
    Set coll = New VBA.Collection

    If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
        coll.Add Application.ActiveInspector.CurrentItem
    Else
        Set Sel = Application.ActiveExplorer.Selection
    
        For i = 1 To Sel.Count
            coll.Add Sel(i)
        Next
    End If

    ' SET COUNTERS
    rol = 1
    indice = 1
    time_record = Format(Now, "yyyymmddhhmm")

    ' SAVE EACH MAIL AS PDF BUT WITHOUT THE HEADER 
    For Each myItem In coll
        
        ' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
        FileName = myItem.SenderName & " - " & myItem.Subject
        FileName = Replace(FileName, ":", "")
        FileName = Replace(FileName, "|", "-")
        FileName = Replace(FileName, "/", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, Chr(34), "")

        If Len(FileName) > 90 Then
            FileName = Left(FileName, 90)
        End If
        
        ' SAVE AS PDF
        Set objInspector = myItem.GetInspector
        Set objDoc = objInspector.WordEditor
        objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & "Mail - " & FileName & ".pdf", 17
        Set objInspector = Nothing
        Set objDoc = Nothing

        rol = rol + 1
        indice = indice + 1
    
    Next myItem

End Sub

Answer 1

David Rowie 写道：Option Explicit 不要改变我的问题的任何内容

没有 Option Explicit 您的代码可以编译。但是，使用显式选项会出现编译错误：

请首先添加 Option Explicit 并更正所有编译错误。

Answer 2

这是从相关邮件中提取互联网 header 的代码。只用了简单的google搜索外观vbaheader信息

Option Explicit
Const DRIVE = "F:\"
Const ROOTPATH = "Mail\"

Sub mail_to_pdf_sof()
    Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object, coll As Object, Sel As Object, objInspector As Object, objDoc As Object
    Dim psName As String, pdfName As String, strFolderpath As String, Path As String, time_record As String, FileName As String
    Dim rol As Integer, indice As Integer, i As Integer
    Dim Header As String '*** The header here
    
    Set outApp = CreateObject("Outlook.Application")
    Set objOutlook = outApp.GetNamespace("MAPI")
    
    ' PATH TO SAVE PDFs
    
    Path = DRIVE & ROOTPATH
    Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
    
    On Error Resume Next
     MkDir Path
    On Error GoTo -1 ' *** Reset error handling
 
    ' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF

    Set coll = New VBA.Collection

    If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
        coll.Add Application.ActiveInspector.CurrentItem
    Else
        Set Sel = Application.ActiveExplorer.Selection
    
        For i = 1 To Sel.Count
            coll.Add Sel(i)
        Next

    End If

    ' SET COUNTERS
    
    rol = 1
    indice = 1
    time_record = Format(Now, "yyyymmddhhmm")

    ' SAVE EACH MAIL AS PDF BUT WITHOUT THE HEADER
    
    For Each myItem In coll
        
        ' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
        
        FileName = myItem.SenderName & " - " & myItem.subject
        FileName = Replace(FileName, ":", "")
        FileName = Replace(FileName, "|", "-")
        FileName = Replace(FileName, "/", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, Chr(34), "")

        If Len(FileName) > 90 Then
        FileName = Left(FileName, 90)
        End If
      
        '*
        '* Get the header for this mail into the string Header
        '* Do whatever you want with it
        '* (merge it with the mail or save as a separate file)
        '*
        Header = GetInetHeaders(myItem)
        
        ' SAVE AS PDF
        
        Set objInspector = myItem.GetInspector
        Set objDoc = objInspector.WordEditor
        objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & "Mail - " & FileName & ".pdf", 17
        Set objInspector = Nothing
        Set objDoc = Nothing

        rol = rol + 1
        indice = indice + 1
    
  Next myItem

End Sub
'*********************************************************************************
'* Get the header from the mailitem
'* https://www.slipstick.com/developer/code-samples/outlooks-internet-headers
'*
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' //techniclee.wordpress.com/
    ' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function

Answer 3

您可以通过保存转发的版本来获取发件人、抄送、时间、收件人、主题，不是密件抄送。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Sub mail_to_pdf_sof()
    
    Dim Path As String
    
    Dim coll As VBA.Collection
    Dim Sel As Selection
    
    Dim i As Long
    Dim rol As Long
    Dim time_record As String
    
    Dim myItem As Object
    
    Dim FileName As String
    
    Dim objInspector As Inspector
    Dim objDoc As Object
        
    ' PATH TO SAVE PDFs
    Path = "F:\"
    
    Path = Path & Format(Date, "yyyy-mm-dd") & " - Mail to PDF" & "\"
    
    On Error Resume Next
    MkDir Path
    On Error GoTo 0
    
    ' GET MAILS SELECTED IN OUTLOOK FOR THE CONVERSION AND SAVE TO PDF
    Set coll = New VBA.Collection
    
    If TypeOf ActiveWindow Is Inspector Then
        coll.add Application.ActiveInspector.currentItem
        
    Else
        Set Sel = ActiveExplorer.Selection
        For i = 1 To Sel.count
            coll.add Sel(i)
        Next
        
    End If
    
    ' SET COUNTERS
    rol = 1
    time_record = Format(Now, "yyyymmddhhmm")
    
    ' SAVE EACH MAIL WITH THE HEADER
    For Each myItem In coll
        
        ' ELIMINATES CHARACTER THAT ARE NOT ALLOWD AND SET A MAX TO FILE NAME LENGTH
        FileName = myItem.SenderName & " - " & myItem.Subject
        FileName = Replace(FileName, ":", "")
        FileName = Replace(FileName, "|", "-")
        FileName = Replace(FileName, "/", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, "\", "-")
        FileName = Replace(FileName, Chr(34), "")
        
        If Len(FileName) > 90 Then
            FileName = Left(FileName, 90)
        End If
        
        'Debug.Print FileName
        
        If myItem.Class = olMail Then
            
            Set myItem = myItem.Forward    ' <----
            
            ' SAVE AS PDF
            Set objInspector = myItem.GetInspector
            Set objDoc = objInspector.WordEditor
            
            objDoc.ExportAsFixedFormat Path & time_record & " - " & rol & " - " & _
              "Mail - " & FileName & ".pdf", 17
              
            myItem.Close olDiscard

            Set objInspector = Nothing
            Set objDoc = Nothing
            
            rol = rol + 1
            
        End If
        
    Next myItem
    
End Sub

使用 header 使用 WordEditor 将邮件保存为 pdf

Save mail with WordEditor as pdf with header

pdf

email

outlook

vba