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)

    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

 

 

End Sub

By: Xaver

Leave a Reply

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