Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Followers 0
Login Register as User

Send serial emails with Excel

09.10.2018 (๐Ÿ‘7764)



With the following Excel file you can send emails as serial emails.

The file is for small circulars or manageable quantities up to 1000 emails per action.

It goes through a simple email address list, and an email is sent to each email address in the Email_To column from the _Text template.

The text template can be easily written in Word and inserted in the text field.

The emails are automatically transferred to Outlook and sent automatically or kept as send drafts in Outlook.

From the email address table, addresses, names, numbers and other data in the text of the email can be automatically taken over placeholders.


Scope of application:

This makes it easy to send serial emails to medium-sized leisure groups, clients, small newsletters in the company.



The following Excel file can be used as a template for sending serial emails with the following features:

1) multiple attachments selectable

2) Emails can be set to CC addresses

3) All fields of the table can be adapted via wildcards in the output email and thus personalized.

3) Transmission time or transmission error as a result



The Excel file is available for download on the CodeDocu page and the vba macro code can be used and optimized at any time.


Macro vba code

The vba macro code is at the connector to the image documentation.


Subject: Outlook, vba macro, excel template for download, serial mail, serial emails, newsletters


Enter station

The excel file consists of a few input fields like

Title of Email (Subject)

Sender Email address and name of the sender (Outlook)

File attachments. (Selectable via the Select button)


Address table

The address table has an Email_To column where to send the emails

is freely adjustable. It is important that you do not completely replace the table but only from external fills with the usual methods.

The table is saved as tblEmails as an Excel variable (Formulas-> Name Variables).



Customize email table

So you can easily expand the table to the right with the right mouse button or delete or rename the example columns Name-Location-Account-Amount.

The content of a column can be exchanged with a placeholder in the email text.

In the example you just have to insert [@Location] into the email text, so that it appears at runtime 72622 Nรผrtingen.

A placeholder is always composed of the square brackets plus a @ in addition to the column header [@Header]



Email text

The email text can be found in the Excel sheet _Text.

The text itself in then in the green text pad. Here you can either write the text directly or write in Word, adjust the color and then simply paste it into the green text box.


Set file attachments.

You can use the button: Select .. choose. In the file dialog: Select Files .. You can select one or more files and accept them with the dialog button: -> Select Files.


Final: send emails

With the button: Send Emails, the emails are then sent in the series.

In the background, Excel opens Outlook in the background and puts the emails in the list to be sent.

After completion of the dispatches, a dialog message appears: Done.

Excel status messages are sent in the left column: #Status_Send.


Excel name variables

The input fields and the table are set in Excel name variables.

You can find the Excel name variables under Menu-> Formulas-> Name variables. Here is also stored that the table is called tblEmails.


The files are then in the Outlook output


In Outlook at the receiver:

As you can see, the serial emails are traded in this case with the Microsoft Outlook client.

The attachments are carried along as you can see and you can also see the repacements in the text content of the actual email


Outlook vs. E-mail client

I use a free email client for download under the Send-Email.dll in CodeDocu.






Vba macro code

Complete macro code


Under Alt-F11 you get into the vba code area.

Here you can find the code under the Excel file-> Module-> Module1

Option Explicit On


'===================< Region: Email >===================


Public Sub Send_Email()

    '-------------< Send_Email() >-------------

    '*Runs trough List and creates single Emails

    '-< init >-

    '*Eingabe Felder Blatt-Header

    Dim sTitle As String

    sTitle = ActiveWorkbook.Names("varTitle").RefersToRange.Value2

    Dim sEmail_From As String

    sEmail_From = ActiveWorkbook.Names("varEmail_From").RefersToRange.Value2

    Dim sName_From As String

    sName_From = ActiveWorkbook.Names("varName_From").RefersToRange.Value2



    '< Text >

    Dim sTemplate As String

    sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text

    '</ Text >

    '-</ init >-


    Dim ws As Worksheet

    Set ws = ActiveSheet    'with button



    '----< Send with Outlook >----

    Dim app_Outlook As Outlook.Application

    Set app_Outlook = New Outlook.Application

    Dim objEmail As Outlook.MailItem


    '<# Optional: Late-Binding >

    'Dim app_Outlook

    'Set app_Outlook = CreateObject("Outlook.Application")

    'Dim objEmail

    '</# Optional: Late-Binding >


    '--< Email einstellen >--


    '< get Table with Emails >

    Dim tblEmails As ListObject   'active Excel-Table with emails

    Set tblEmails = ws.ListObjects("tblEmails")

    '</ get Table with Emails >


    '-< get Headers >-

    Dim sHeaders As String

    sHeaders = ""

    Dim iColumn As Integer

    For iColumn = 1 To tblEmails.ListColumns.Count

        Dim sHeader As String

        sHeader = tblEmails.Range(1, iColumn).Value

        sHeaders = sHeaders & ";" & sHeader


    sHeaders = Replace(sHeaders, ";""", 1, 1)

    Dim arrHeaders

    arrHeaders = Split(sHeaders, ";")

    '-</ get Headers >-


    Dim iCol_Email_To As Integer

    iCol_Email_To = get_Column("Email_To")

    Dim iCol_Email_Cc As Integer

    iCol_Email_Cc = get_Column("Emails_Cc")


    '----< @Loop: all List-Rows >----

    Dim iRow As Integer

    For iRow = 2 To tblEmails.ListRows.Count

        '< get Email Address >

        Dim sAddress_To As String

        sAddress_To = tblEmails.Range(iRow, iCol_Email_To).Value

        Dim sAddresses_CC As String

        sAddresses_CC = tblEmails.Range(iRow, iCol_Email_Cc).Value

        '</ get Email Address >


        If sAddress_To Like "*@*.*" Then

            '----< Email_To is OK >----

            '-< Replace all Placeholders >-

            Dim sText As String

            sText = sTemplate


            Dim iCol As Integer

            For iCol = 1 To tblEmails.ListColumns.Count

                Dim sPlaceholder As String

                sPlaceholder = tblEmails.Range(1, iCol)

                Dim sValue As String

                sValue = tblEmails.Range(iRow, iCol)

                '< replace >

                If Not sPlaceholder Like "" Then

                    sText = Replace(sText, "[@" & sPlaceholder & "]", sValue, , , vbTextCompare)

                End If

                '</ replace >


            '-</ Replace All Placeholders >-


            '--< Send Email >--

            Dim status_Send As String '?date

            '<< send >>

            status_Send = Send_Email_to_Address(sAddress_To, sTitle, sText, sAddresses_CC)

            '<</ send >>

            '*show dtSend or error

            tblEmails.Range(iRow, 1).Value = status_Send

            '--</ Send Email >--


            '----</ Email_To is OK >----

        End If



    '----</ @Loop: all List-Rows >----


    '< Abschluss >

    Set objEmail = Nothing

    Set app_Outlook = Nothing

    '</ Abschluss >


    MsgBox "Fertig", vbInformation, "Fertig"


    '----</ Send with Outlook >----

    '-------------</ Send_Email() >-------------

End Sub




Public Function Send_Email_to_Address(ByVal sAddress_To As StringByVal sTitle As StringByVal sText As StringByVal sAddresses_CC As StringAs String

    '-------------< Send_Email_to_Address() >-------------

    '*sends a single email

    '*uses: outlook

    '< init >

    On Error Resume Next

    '< check >

    If sAddress_To Like "" Then

        Send_Email_to_Address = "no: [Email_To] is empty"

        Exit Function

    End If

    '</ check >




    '< outlook >

    Dim app_Outlook As Object

    Set app_Outlook = CreateObject("Outlook.Application")

   '</ outlook >


    Dim sFiles As String

    sFiles = ActiveWorkbook.Names("varFiles").RefersToRange.Value2



    '--< Send Email >--

    Dim objEmail As Object

    Set objEmail = app_Outlook.CreateItem(0)

    objEmail.To = sAddress_To

    If Not sAddresses_CC Like "" Then

        objEmail.CC = sAddresses_CC

        '*via address;addess is ok

        '        Dim arrAddresses() As String

        '        arrAddresses = Split(sAddresses_CC, ";")

        '        Dim Address_CC

        '        For Each Address_CC In arrAddresses

        '            objEmail.CC.Add Address_CC

        '        Next

    End If


    objEmail.Subject = sTitle

    objEmail.Body = sText       '*.body for Text, Richtext

    'objEmail.HTMLBody = sHTML  '*.HTMLBody for HTML


    '-< Attach Files >-

    Dim arrFiles

    arrFiles = Split(sFiles, ";")

    Dim sFile

    For Each sFile In arrFiles

        If Not sFile Like "" Then

            If Not sFile Like "*:*" Then

                sFile = ActiveWorkbook.Path & "\" & sFile

            End If

            objEmail.Attachments.Add sFile

        End If


    '-</ Attach Files >-



    '< send >

    Dim sAutosend As String

    sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text

    If sAutosend Like "*Sofort*" Then

        objEmail.Display False



        objEmail.Display False

        'objEmail.Display bVisible   '*no visible=true because of : wait on outlook

    End If

    '</ send >

    '--</ create Email >--


    '< Abschluss >

    Set objEmail = Nothing

    Set app_Outlook = Nothing

    '</ Abschluss >


    If Err.Number <> 0 Then

        '< error >

        'MsgBox "Error on Email=" & sAddress_To & vbCrLf & Err.Description & vbCrLf & "Check Syntax of Email-Address ", vbCritical, "Error on sending.."

        Send_Email_to_Address = "no: " & Err.Description

        '</ error >


        '< ok >

        '*return dtSend

        Send_Email_to_Address = "ok: " & Now

        '</ ok >

    End If


    '-------------</ Send_Email_to_Address() >-------------

End Function

'===================</ Region: Email >===================



'===================< Region: Helper-Functions >===================

Private Function get_Column(sFind_Header As StringAs Integer

    '-------------< get_Column() >-------------

    '*find Column with Header

    Dim tblEmails As ListObject   'active Excel-Table with emails

    Set tblEmails = ActiveSheet.ListObjects("tblEmails")


    Dim iReturn

    iReturn = -1


    Dim iColumn As Integer

    For iColumn = 1 To tblEmails.ListColumns.Count

        Dim sHeader As String

        sHeader = tblEmails.Range(1, iColumn).Value

        If sHeader Like sFind_Header Then

            iReturn = iColumn

            Exit For

        End If



    get_Column = iReturn

    '-------------</ get_Column() >-------------

End Function






'*Reference Microsoft Scripting Runtime

Public Sub Select_File()

    '-----------< Select_File() >-----------


    '------< Select_File() >------

    '--< File-Dialog >--

    Dim objFiledialog As FileDialog

    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

    objFiledialog.AllowMultiSelect = True

    objFiledialog.ButtonName = "->Select Files"

    objFiledialog.Filters.Add "Add Files""*.*"

    objFiledialog.Title = "Select Files.."

    objFiledialog.InitialView = msoFileDialogViewTiles

    objFiledialog.InitialFileName = ActiveWorkbook.Path

    objFiledialog.AllowMultiSelect = True

    If Not objFiledialog.Show() = True Then

        Exit Sub

    End If

    '--< File-Dialog >--


    '-< check >-

    '</ Ordner ist leer >

    If objFiledialog.SelectedItems().Count = 0 Then

        Exit Sub

    End If

    '</ Ordner ist leer >

    '-</ check >-


    Dim sFilename As String

    Dim sFiles As String

    sFiles = ""

    '----< @Loop: Files >----

    Dim iFile As Integer

    For iFile = 1 To objFiledialog.SelectedItems.Count

        '------< Loop.Item  >------



        '< get selection >

        sFilename = objFiledialog.SelectedItems(iFile)

        '</ get selection >


        '< correct >

        sFilename = Replace(sFilename, ActiveWorkbook.Path & "\""", 1, 1, vbBinaryCompare)

        '</ correct >



        '< add >

        sFiles = sFiles & ";" & sFilename

        '</ add >


    '----</ @Loop: Files >----

    '< correct >

    sFiles = Replace(sFiles, ";""", 1, 1, vbBinaryCompare)

    '</ correct >



    '< write_into_cell >

    ActiveWorkbook.Names("varFiles").RefersToRange.Value2 = sFiles

    '</ write_into_cell >

    '-----------</ Select_File() >-----------

End Sub

'===================</ Region: Helper-Functions >===================






Vba references:

Under vba code-> Extras-> References

Can one adjust the available references to Microsoft Outlook xx.x Object Library or a suitable version

And on Microsoft Office xx.x Object Library for the file dialog to select the file attachments