将电子邮件正文保存到 Word 文档答案

【问题标题】：Save email body to Word document将电子邮件正文保存到 Word 文档
【发布时间】：2019-08-29 05:56:18
【问题描述】：

我的目标是将活动电子邮件的正文从 Outlook 复制到 MS Word，然后将 Word 保存到指定的目的地。

代码

Dim objMail as Outlook.MailItem
Dim objWord As Object
Dim objDocument As Object
Dim objFSO As Object
Dim objTextStream As Object

Set objMail = Application.ActiveInspector.CurrentItem
Set objWord = CreateObject("Word.Application")
Set objDocument = objWord.Documents.Add
objMail.GetInspector().WordEditor.Range.FormattedText.Copy
objDocument.Range.Paste

方法对吗？

【问题讨论】：

objMail.Body 是邮件的正文。不知道如何将其粘贴到 Word 中。

标签： vba outlook ms-word office-2016

【解决方案1】：

您可以检查您是否真的选择了一封电子邮件（在列表中或已打开）并复制其格式化的正文，如下所示：

Private Sub CopyEMailBodyToWord()
    Dim objOutlook As Outlook.Application
    Dim objMail As Object      'Outlook.MailItem, but has to be checked later
    Dim objWord As Object
    Dim objDocument As Object

    Set objOutlook = Outlook.Application

    Select Case TypeName(objOutlook.ActiveWindow)
    Case "Explorer"     ' get current item in list view
        Set objMail = objOutlook.ActiveExplorer.Selection.Item(1)
    Case "Inspector"    ' get open item
        Set objMail = objOutlook.ActiveInspector.CurrentItem
    End Select

    If objMail.Class = olMail Then
        Set objWord = GetObject(, "Word.Application")
        If objWord Is Nothing Then Set objWord = CreateObject("Word.Application")
        Set objDocument = objWord.Documents.Add

        ' copy formatted body:
        objMail.GetInspector.WordEditor.Range.FormattedText.Copy
        objDocument.Range.Paste

        ' or copy text only:
        'objDocument.Range.Text = objMail.Body

        With objWord.FileDialog(msoFileDialogSaveAs)
            .Title = "Save ..."
            .InitialFileName = objWord.Options.DefaultFilePath(wdDocumentsPath) & _
                "\" & objMail.Subject & ".docx"
            If .Show <> False Then
                objDocument.SaveAs _
                    FileName:=.SelectedItems(1), _
                    AddToMru:=False
            End If
        End With

    End If
End Sub

【讨论】：

【解决方案2】：

这是你想要做的吗？

Option Explicit
Public Sub Example()
    Dim Email As Outlook.MailItem
    Set Email = Application.ActiveInspector.CurrentItem

    'Word document
    Dim wdApp As Word.Application
    Set wdApp = CreateObject("Word.Application")

    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Add
        wdDoc.Activate

    Dim wdRange As Word.Range
    Set wdRange = wdDoc.Range(0, 0)

    'Add email to the document
    wdRange.Text = Email.Body

    wdApp.Visible = True

    wdDoc.SaveAs2 FileName:="C:\Temp\Example.docx", FileFormat:= _
        wdFormatXMLDocument, CompatibilityMode:=15
End Sub

您可能还想与ActiveWindow.Class 合作，以避免您的CurrentItem 出现任何错误

【讨论】：