Open .rtf Attachment and Paste Contents in Current Email Body

automation, ms-access, outlook, vba

Solution

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

Problem

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 ```

Original source