Open a Word document from Excel and paste the contents to body of Outlook mail

Question

I want, from Excel, to send automatic mails through MS Outlook.

The problem is writing the body of the mail. I have a separate Word file for each employee, with a hyperlink to it, in an Excel cell. I want to open the Word file and copy, with the same format, all which is in the Word document then paste into the body of the mail.

In my Excel workbook, columns A to E are as below.

Column A: Employee Name
Column B: To Mail ID
Column C: CC Mail ID
Column D: Subject
Column E: Hyperlink to Word file (Need to open the document to copy and paste the same in body of the mail)
Column F to Z: Attachment (Any type of attachment)

Sub Send_Files()

'Make a list in Sheets("Sheet1") with :

'In column A : Names of the people
'In column B : E-mail addresses
'In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

'The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
'and file name(s) in column C:Z it will create a mail with this information and send it.

'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

    If cell.Value Like "?*@?*.?*" And _
        Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .to = cell.Value
            .cc = cell.Offset(0, 1).Value
            .Subject = cell.Offset(0, 2).Value
            .Body = "Hi" & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell

            .Send  'Or use .Display
        End With
        Set OutMail = Nothing
    End If[enter link description here][1]
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Snap shot of the body of the mail content.

Answer 1

The trick is in getting the Word document contents pasted with the formatting. For that, you need to attach MS Word is the editor for an Outlook mail item.

Also, from your example Word doc above, you wanted the email to be personalized for the user. So modify the Word doc to read "Dear XXXNAMEXXX", then perform a find/replace (as shown in the code).

Option Explicit

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutMailEditor As Object
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    Set WordApp = CreateObject("Word.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            'copy/paste the body of the email and change the name
            Set OutMailEditor = OutMail.GetInspector.WordEditor
            Set WordDoc = WordApp.documents.Open(Filename:=cell.Offset(0, 3).Value, ReadOnly:=True)
            WordDoc.Content.Copy
            OutMailEditor.Range.Paste
            With OutMailEditor.Range.Find
                .Text = "XXXNAMEXXX"
                .Replacement.Text = cell.Offset(0, -1).Value
                .Wrap = 1
                .Forward = True
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2
            End With

            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .Subject = cell.Offset(0, 2).Value
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With
            Set OutMail = Nothing
            Set WordDoc = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    Set WordApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub