VBA Outlook 使用 wordEditor 将邮件保存为 pdf WITH HEADER答案

【问题标题】：Save mail with WordEditor as pdf with headerVBA Outlook 使用 wordEditor 将邮件保存为 pdf WITH HEADER
【发布时间】：2021-07-20 09:42:35
【问题描述】：

我想制作一个 Outlook 宏来保存邮件正文和 HEADER，就好像它是由 Outlook 或 pdfcreator 打印出来的一样。发件人、抄送、密送、时间、收件人、主题是必须在 pdf 中的数据。

使用这篇文章和其他文章：

Print mail item as pdf

我编写了这个宏：

在 Outlook 中接收选定的邮件
在硬编码文件夹中创建一个新文件夹
使用 wordeditor 将正文邮件打印为 PDF

我的问题是 wordEditor objecto 没有保存 mailItem 的 HEADER。这对我来说很重要，因为我有发送者、发送时间、电子邮件地址、主题等的信息我想知道如何从 wordEditor 对象中添加标题。

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

不知道有没有人知道这个问题的合理解决方案，谢谢！

【问题讨论】：

选项显式在哪里？另请阅读最小、完整和可验证示例：stackoverflow.com/help/mcve
我是编码的初学者。它是 VBA，它很容易理解。复制并粘贴它就可以了。如果有人知道我要求的主题，他或她肯定知道我正在暴露的问题，因为它真的很常见。选项显式不会改变我的问题

标签： vba email pdf outlook

【解决方案1】：

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

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

【讨论】：

非常感谢，但是附件列表丢失了。你不知道邮件有没有附件。但无论如何这是一个很好的解决方案。谢谢！
由于转发项是可编辑的，我可以添加附件列表和其他东西。再次感谢你！很好的帮助！

【解决方案2】：

这是从相关邮件中提取 Internet 标头的代码。只用了简单的google搜索outlook vba头信息

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

【讨论】：

非常感谢，斯图尔。但问题不在于获取标题数据（mailItem.senderName 等是另一种选择），正如标题和我删除的评论之一所说，它是将其包含在正文邮件之前的 pdf 中，就像你从outlook打印出来。合并它们并不简单，因为邮件正文是只读对象。创建新邮件并复制原始邮件以进行编辑也不是一件容易的事。 HTMLBody 通常具有嵌入的图像，并且将它们复制到新邮件中并不容易，因为它们必须作为附件一一添加。
这不是一个编码服务，您可以在其中陈述您的要求并返回准备好运行的调试代码。你需要自己付出一些努力。向我们展示您到目前为止所做的尝试。另请阅读最小、完整和可验证示例：stackoverflow.com/help/mcve
...必须补充一下，需要临时保存附件来获取文件夹路由以将其传递给add方法...一团糟
一切皆有可能。只需一步一步地编写代码，不要再假设它只是几行代码，或者可以一次解决所有问题。 Babysteps，如果你喜欢....关于制作 PDF 的最后一步，您可以从 Outlook 的 VBA 中启动 Word，然后访问所有 Word 功能。但是，话又说回来，婴儿步骤......
@David_Rowie 回复：“因为邮件正文是只读对象。”。您可以编辑邮件正文。在 VBA 中，请参阅 stackoverflow.com/questions/54347992/…

【解决方案3】：

David Rowie 写道：Option Explicit 不会改变我的问题

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

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

【讨论】：

考虑删除它，因为它不是答案。
附上图片以显示 Option Explicit 至关重要的唯一方法。部分解决方案。