Блог

Моя цель — скопировать и перенести текст активной электронной почты из 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
  

Это правильный путь?

Вы можете проверить, действительно ли вы выбрали электронное письмо (либо в списке, либо открыто), и скопировать его форматированное тело следующим образом:

 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) amp; _
                "" amp; objMail.Subject amp; ".docx"
            If .Show <> False Then
                objDocument.SaveAs _
                    FileName:=.SelectedItems(1), _
                    AddToMru:=False
            End If
        End With

    End If
End Sub
  

Это то, что вы пытаетесь сделать?

 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:TempExample.docx", FileFormat:= _
        wdFormatXMLDocument, CompatibilityMode:=15
End Sub
  

Возможно, вы также захотите поработать с ActiveWindow.Класс, чтобы избежать ошибок на вашем CurrentItem