Open .rtf Attachment and Paste Contents in Current Email Body

Question

We have an Access database that is using the SendObject method to export the report as an attachment to an email.

What I need to be able to do is open the attachment, copy the text (with formatting) and paste that into the body of the generated email and delete the file.

I've got the code to strip the attachment and open it, but I'm not sure how to copy everything in the Word document and paste it back to the original email.

Any help would be greatly appreciated! If there is a simpler approach, please let me know.

Sub olAttachmentStrip()
  Dim strFilename As String
  Dim strPath As String
  Dim olItem As Outlook.MailItem
  Dim olAtmt As Outlook.Attachments
  Dim olInspector As Outlook.Inspector
  Dim appWord As Word.Application
  Dim docWord As Word.Document

  strPath = "C:\temp\"

  Set olInspector = Application.ActiveInspector
  If Not TypeName(olInspector) = "Nothing" Then
    If TypeName(olInspector.CurrentItem) = "MailItem" Then
        Set olItem = olInspector.CurrentItem
        Set olAtmt = olItem.Attachments
            olAtmt.Item(1).SaveAsFile strPath & olAtmt.Item(1).DisplayName
            strFilename = strPath & olAtmt.Item(1).DisplayName
            'olAtmt.Item(1).Delete
    Else
    MsgBox "Something went horribly wrong."
    End If
  End If

  Set appWord = CreateObject("Word.Application")
  appWord.Visible = False 
  Set docWord = appWord.Documents.Open(strFilename)
  Stop  '<==  This is where I'm stuck!
  Set docWord = Nothing
  Set appWord = Nothing
End Sub

Answer 1

Since you already have the code to extract the attachment. The next step is to simply open the file, copy the complete text and paste it in the current email.

Try this (TRIED AND TESTED)

Option Explicit

Sub Sample()
    Dim doc As Object, sel As Object
    Dim oWord As Object, oDoc As Object, wRng As Object


    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oWord = GetObject(, "Word.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oWord = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Open the Attachement
    Set oDoc = oWord.Documents.Open(FileName:="C:\MyDocument.rtf", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=0, XMLTransform:="", _
        Encoding:=1200)

    '~~> Get the comeplete text and copy it
    Set wRng = oDoc.Range
    wRng.Copy

    '~~> Close word Doc
    oDoc.Close

    '~~> Paste it in active email
    Set doc = ActiveInspector.WordEditor
    Set sel = doc.Application.Selection
    sel.Paste

    '~~> Clean up
    Set wRng = Nothing: Set oDoc = Nothing: Set oWord = Nothing
End Sub