How to copy formatted text from Word document to Rich Text Format email body?

user_17420363 0
Viewed 133

This macro drafts an email in Rich Text Format. (HTML body is not an option for me in this case.)

I need to populate the body of the email with default text and two attachments placed in the middle of the email. (Path1 and Path2).

I find formatting body text with RTF less intuitive than HTML. Copying the body of the email from a dynamic Word document seems like a good solution.

(I did not write the majority of this code, just trying to improve it for this purpose.)

Option Explicit
Function send_mail_rich_text(ByVal send_to As String, ByVal 
    mail_subject As String, ByVal mail_content As Range, ByVal 
    cc_list As String)

    Dim oOlApp As Object    ' Outlook.Application
    Dim oOlMItem As Object  ' Outlook.MailItem
    Dim oWdDoc As Object    ' Word.Document
    
    Dim Path1 As String
    Dim Path2 As String
    
    Path1 = "C:\Users\DegenTrader\Desktop\Wallet Allocations 42069xD.xlxs"
    Path2 = "C:\Users\DegenTrader\Desktop\Hash Rate Info.xlsx"
    
    Err.Clear

    Set oOlApp = CreateObject("Outlook.Application")
    Set oOlMItem = oOlApp.CreateItem(olMailItem)

    ' Range can be copied directly as given as Range via function call
    'mail_content.Copy

    ' On Error Resume Next   ' activate it after debugging
    With oOlMItem
        .To = send_to
        .Subject = mail_subject
        .BodyFormat = 3 ' 3=RichTextFormat

        'Set oWdDoc = .GetInspector.WordEditor

        ' by this you paste below your signature
        ' oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range.Paste

        .Display
    End With

    Application.CutCopyMode = False

    If Err.Number <> 0 Then
        send_mail_rich_text = "error"
    ElseIf oOlMItem.Sent = True Then
        send_mail_rich_text = "sent"
    Else
        send_mail_rich_text = "no error, but not sent"
    End If
End Function

Sub TestSendmailFunction()
    Debug.Print send_mail_rich_text("shiba.inu@DogeCoin.com", "HODL- To the Moon!", ActiveSheet.Range("B2:C3"), "Cheems@reddit.com")
End Sub
ms-word outlook vba excel
3 Answers

To add attachments you can use the Attachments.Add method which creates a new attachment in the Attachments collection. For example:

Sub AddAttachment() 
 Dim myItem As Outlook.MailItem 
 Dim myAttachments As Outlook.Attachments 
 
 Set myItem = Application.CreateItem(olMailItem) 
 Set myAttachments = myItem.Attachments 
 myAttachments.Add "C:\Test.doc", _ 
 olByValue, 3, "Test" 
 myItem.Display 
End Sub

The Position parameter applies only to email messages using the Rich Text format: it is the position where the attachment should be placed within the body text of the message. A value of 1 for the Position parameter specifies that the attachment should be positioned at the beginning of the message body. A value 'n' greater than the number of characters in the body of the email item specifies that the attachment should be placed at the end. A value of 0 makes the attachment hidden.

To send the email you need to replace the Display method with the Send one.

user_16033510

When calling MailItem.Attachments.Add, specify the attachment position using the Position parameter (parameter number 3). It is a good idea to have \objattph RTF placeholder tag placed at that position.

user_3320590

Not apparent why Excel is involved. This code is for Outlook.

Option Explicit

Function send_mail_rich_text(ByVal send_to As String, ByVal mail_subject As String)

    ' This code is for Outlook.
    
    Dim oOlMItem As MailItem
    
    Dim Word As New Word.Application
    Dim oWdDoc As Word.Document
    
    Dim Doc As String
    Doc = "C:\Users\DegenTrader\Desktop\Test.docx"
    'Sample text for Test.docx
    'Hello Team:
    '
    '
    '
    'Thank You
    
    Dim Path1 As String
    Dim Path2 As String
    
    Path1 = "C:\Users\DegenTrader\Desktop\Wallet Allocations 42069xD.xlxs"
    Path2 = "C:\Users\DegenTrader\Desktop\Hash Rate Info.xlsx"
    
    Set oWdDoc = Word.Documents.Open(Doc, ReadOnly:=True)
    
    Word.Selection.WholeStory
    Word.Selection.copy

    oWdDoc.Close
    Word.Quit

    Set oOlMItem = CreateItem(olMailItem)
        
    With oOlMItem
    
        .To = send_to
        .Subject = mail_subject
        .BodyFormat = 3     ' 3=RichTextFormat
        
        Set oWdDoc = .GetInspector.WordEditor
        oWdDoc.Paragraphs(1).Range.PasteAndFormat Type:=wdFormatOriginalFormatting
        
        ' Adjust character position 14 and 15 as needed.
        .Attachments.Add Path1, , 14
        .Attachments.Add Path2, , 15
        
        .Display
        
    End With
    
    If oOlMItem.Sent = True Then
        send_mail_rich_text = "sent"
    Else
        send_mail_rich_text = "not sent"
    End If
    
End Function


Sub TestSendmailFunction()
    Debug.Print send_mail_rich_text("someone@somewhere.com", _
      "Word document content and attachments")
End Sub

Code not in Outlook

Option Explicit

Function send_mail_rich_text(ByVal send_to As String, ByVal mail_subject As String)

    ' Late binding.
    ' Reference to Outlook and Word Object libraries not required
    Dim oOlApp As Object    ' Outlook.Application
    Dim oOlMItem As Object  ' Outlook.MailItem
    
    Dim Word As Object      ' Word.Application
    Set Word = CreateObject("Word.Application")
    
    Dim oWdDoc As Word.Document
    
    Dim Doc As String
    Doc = "C:\Users\DegenTrader\Desktop\Test.docx"
    'Sample text for Test.docx
    'Hello Team:
    '
    '
    '
    'Thank You
    
    Dim Path1 As String
    Dim Path2 As String
    
    Path1 = "C:\Users\DegenTrader\Desktop\Wallet Allocations 42069xD.xlxs"
    Path2 = "C:\Users\DegenTrader\Desktop\Hash Rate Info.xlsx"
    
    Set oWdDoc = Word.Documents.Open(Doc, ReadOnly:=True)
    
    Word.Selection.WholeStory
    Word.Selection.Copy

    oWdDoc.Close
    Word.Quit
    
    Set oOlApp = CreateObject("Outlook.Application")
    Set oOlMItem = oOlApp.CreateItem(0)     ' 0 - Mailitem
    
    With oOlMItem
    
        .To = send_to
        .Subject = mail_subject
        .BodyFormat = 3     ' 3=RichTextFormat
        
        Set oWdDoc = .GetInspector.WordEditor
        oWdDoc.Paragraphs(1).Range.PasteAndFormat Type:=wdFormatOriginalFormatting
        
        ' Adjust character position 14 and 15 as needed.
        .Attachments.Add Path1, , 14
        .Attachments.Add Path2, , 15
        
        .Display
        
    End With
    
    If oOlMItem.Sent = True Then
        send_mail_rich_text = "sent"
    Else
        send_mail_rich_text = "not sent"
    End If
    
End Function
user_15714070
Related