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

时间:2019-04-08 06:30:15

标签: vba outlook ms-word outlook-vba office-2016

我的目标是将活动电子邮件的副本和过去的内容从Outlook复制到MS 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

这是正确的方法吗?

2 个答案:

答案 0 :(得分:2)

您可以检查是否确实选择了电子邮件(在列表中还是已打开)并按以下方式复制其格式的正文:

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

答案 1 :(得分:0)

这是您要做什么吗?

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

上出现任何错误