Excel VBA add Email body as text from a word document

Question

How do I send Emails to various people attaching individualized documents and setting parts of the Email body as text from a word document (Individualized Addressing, then the Body from Word and then my signature).

Right now everything works except of the body for the Emails. I'd really appreciate your help.

Sub Send_Files()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim html, name, address, age, department
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim Doc As String
    Dim wb1 As Workbook
    Dim Fname1 As String
    Dim strbody As String

    Doc = Range("E37").Value
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)
    Word.Selection.WholeStory
    Word.Selection.Copy
    strbody = ActiveSheet.Paste
    WordDoc.Close
    Word.Quit

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

    Set sh = Sheets("Daten")

    Set OutApp = CreateObject("Outlook.Application")

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

        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

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

            With OutMail
            '.Display 'here

                .To = cell.Value
                .CC = Range("Input!E4").Value
                .Subject = Range("F1").Value
                .HTMLBody = "<br>" & Range("A45").Value & "<br>" & strTemp & "<br>" & .HTMLBody

                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

            .Display 'here

            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

Answer 1

Here is quick example that will copy whole Word document and add it to the email body using strbody

Option Explicit
Public Sub Example()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim Doc As String
    Dim strbody As String

    Doc = Range("E37").Text
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)
        Word.Selection.WholeStory
        strbody = Word.Selection

    Debug.Print strbody

    WordDoc.Close
    Word.Quit

    Set sh = Sheets("Daten")
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

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

            With OutMail
                .To = cell.Value
                .CC = ""
                .Subject = Range("F1").Value
                .HTMLBody = "<br>" & Range("A45").Value & _
                            "<br>" & strbody & "<br>" & .HTMLBody

                .Display 'here
            End With
        End If
    Next 'cell

End Sub

---

To keep the formatting and signature try following example

Option Explicit
Public Sub Example()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim Word As New Word.Application
    Dim WordDoc As Word.Document
    Dim wdDoc As Word.Document
    Dim Doc As String
    Dim strbody As Variant ' String

    Doc = Range("E37").Text
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)

    Word.Selection.WholeStory
    Word.Selection.Copy

    WordDoc.Close
    Word.Quit

    Set sh = Sheets("Daten")
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

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

            With OutMail
                .To = cell.Value
                .CC = ""
                .Subject = Range("F1").Value
                .Display 'here

                 WordDoc.Paragraphs(1).Range. _
                         InsertBefore sh.Range("A45").Value

                 WordDoc.Paragraphs(2).Range. _
                         PasteAndFormat Type:=wdFormatOriginalFormatting
            End With
        End If
    Next 'cell
End Sub