Excel VBA Email tool

I have a problem with my VBA. I want to 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. Thanks very much in advance. Best, X


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)



    strbody = ActiveSheet.Paste




    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



End Sub

By: Xaver

Leave a Reply

Your email address will not be published. Required fields are marked *