Microsoft Office Forums - View Single Post - [Solved] copy and paste Outlook Email bodytext to Word document

gmayor · 08-25-2015, 09:41 PM

It has been a while since I programmed for Outlook 2003, but provided you have Outlook configured with Word as its editor and you have the message opened in the editor, with the required text selected, the following should copy that selected text to a bookmarked location (here bmMessageText) in a named document ("C:\Path\DocumentName.doc"), but I don't have Outlook 2003 available to check it. The macro uses the requested wdFormatSurroundingFormattingWithEmphasis (20), but I might be more inclined to use plain text (2) which will adopt the format at the insertion point.

Code:

Option Explicit

Sub CopyMessage()
Dim wdApp As Object
Dim objDoc As Object
Dim oBM As Object
Dim bFound As Boolean

    On Error GoTo err_Handler
   
    If TypeName(ActiveWindow) = "Inspector" Then
        If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
            ActiveInspector.WordEditor.Application.Selection.Copy
        Else
            MsgBox "Nothing to copy"
            GoTo lbl_Exit
        End If
    Else
        MsgBox "Nothing to copy"
        GoTo lbl_Exit
    End If

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If

    On Error GoTo err_Handler
    Set objDoc = wdApp.Documents.Open("C:\Path\DocumentName.doc")
    wdApp.Visible = True
    wdApp.Activate
    For Each oBM In objDoc.bookmarks
        If oBM.Name = "bmMessageText" Then
            oBM.Range.PasteSpecial DataType:=20
            bFound = True
            Exit For
        End If
    Next oBM
    If Not bFound Then
        MsgBox ("Bookmark name 'bmMessageText' not found.")
        GoTo lbl_Exit
    End If
    objDoc.Save
lbl_Exit:
    Set objDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
err_Handler:
    MsgBox "Uncorrected error number " & Err.Number & vbCr & _
           Err.Description
    GoTo lbl_Exit
End Sub