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