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

Count
Followers 0
Login Register as User

Serien-Emails senden mit Excel

09.10.2018 (👁34018)


Beschreibung:

Mit der folgenden Excel-Datei kann man Emails als Serien-Emails versenden.

Die Datei dient für kleine Rundschreiben oder überschaubare Mengen bis zu 1000 Emails pro Aktion.

Dabei wird eine einfache Email-Adress-Liste durchlaufen, und an jede Email-Adresse in der Email_To Spalte wird eine Email aus der _Text-Vorlage gesandt.

Die Textvorlage kann ganz einfach in Word geschrieben werden und im Text-Feld eingefügt werden.

Die Emails werden automatisch an Outlook übergeben und automatisch versendet oder als Sende-Entwürfe in Outlook gehalten.

Aus der Email-Adress-Tabelle können Adressen, Namen, Nummern und sonstige Daten in den Text der Email automatisch über Platzhalter übernommen werden.

 

Anwendungsbereich:

Damit ist das Senden von Serien-Emails an mittelgroße Freizeit-Gruppen, Mandanten, kleine Rundschreiben in der Firma einfach gehalten.

 

Features:

Folgende Excel-Datei kann als Vorlage zum Versenden von Serien-Emails mit folgenden Features:

1) mehrere Anhänge auswählbar

2) Emails an CC Adressen einstellbar

3) Alle Felder der Tabelle können über Platzhalter in der Ausgabe-Email angepasst und somit personalisiert werden.

3) Sende-Zeit oder Sendefehler als Ergebnis

Download:

Die Excel-Datei ist zum Download auf der CodeDocu Seite und der vba Makro-Code kann jederzeit verwendet und optimiert werden.

 

Makro-vba Code

Der vba Makro Code ist am Anschluss an die Bild-Dokumentation.

Betrifft: Outlook, vba Makro, Excel Vorlage zum Download, Serienmail, SerienEmails, Rundschreiben

Sender eingeben

Die Excel-Datei besteht aus ein paar Eingabefeldern wie

Titel der Email (Subject)

Absender Email-Adresse und Name des Absenders (Outlook)

Datei-Anhänge. (Wählbar über den Select-Button)

Adress-Tabelle

Die Adress-Tabelle besitzt eine Email_To Spalte wohin die Emails gesendet werden sollen,

ist frei einstellbar. Wichtig ist dabei, dass man die Tabelle nicht komplett tauscht sondern nur von Extern auffüllt mit den üblichen Methoden.

Die Tabelle ist als tblEmails gespeichert als Excel-Variable (Formeln->Namensvariablen).

Email-Tabelle anpassen

Man kann also ohne Probleme die Tabelle nach rechts erweitern mit der rechten Maustaste oder die Beispiel-Spalten Name-Ort-Konto-Betrag löschen oder umbenennen.

Der Inhalt einer Spalte kann mit einem Platzhalter in dem Email-Text ausgetauscht werden.

Im Beispiel muss man nur [@Ort] in den Email-Text einfügen, damit dort zur Laufzeit 72622 Nürtingen erscheint.

Ein Platzhalter setzt sich immer aus den Eckigen Klammern plus ein @  ergänzend zur Spalten-Überschrift zusammen  [@Header]

         

Email-Text

Dem Email-Text findet man in dem Excel-Blatt _Text.

Der Text selbst in dann in dem grünen Text-Pad. Hier kann man den Text entweder direkt schreiben oder in Word schreiben, farblich anpassen und anschliessend einfach in das Grüne Textfeld einfügen.

Datei-Anhänge festlegen.

Dateien können Sie über den Button: Select.. auswählen. In dem Datei-Dialog: Select Files.. kann man eine oder mehrere Dateien auswählen und mit dem Dialog-Button:->Select Files übernehmen.

Final: Send Emails

Mit dem Button: Send Emails werden die Emails dann in der Serie versandt.

Dabei öffnet Excel im Hintergrund Outlook und stellt die Emails in die zu-Versenden Liste.

Nach Abschluss der Versendungen erscheint eine Dialog-Meldung: Fertig.

Die Status-Meldungen des Email-Versands von Excel werden in der linken Spalte: #Status_Send geschrieben.

 

Excel-NamensVariablen

Die Eingabe-Felder und die Tabelle sind in Excel-Namensvariablen eingestellt.

Man findet die Excel Namensvariablen unter Menü->Formeln->Namensvariablen. Hier ist auch gespeichert, dass die Tabelle tblEmails heisst.

Die Dateien sind dann im Outlook-Ausgang

In Outlook beim Empfänger:

Wie man sieht werden die Serien-Emails in diesem Fall mit dem Microsoft Outlook Client gehandelt.

Dabei werden die Anhänge mitgeführt wie man sehen kann und man sieht auch die Repacements in dem Text-Content der eigentlich Email

Outlook vs. Email-Client

Einen freien Email-Client verwende ich unter der Send-Email.dll in CodeDocu zum Download.

Vba Makro Code

Kompletter Makro Code

Unter Alt-F11 kommt man in den vba Code-Bereich.

Hier findet man den Code unter der Excel-Datei->Module->Modul1

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

    Next

    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 >

            Next

            '-</ 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

 

    Next

    '----</ @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

    Next

    '-</ Attach Files >-

 

 

    '< send >

    Dim sAutosend As String

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

    If sAutosend Like "*Sofort*" Then

        objEmail.Display False

        objEmail.Send

    Else

        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 >

    Else

        '< 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

    Next

 

    get_Column = iReturn

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

End Function

 

 

 

 

 

'*Reference Microsoft Scripting Runtime    http://www.microsoft-programmierer.de/Details?d=1076

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  >------

        DoEvents

 

        '< get selection >

        sFilename = objFiledialog.SelectedItems(iFile)

        '</ get selection >

 

        '< correct >

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

        '</ correct >

 

 

        '< add >

        sFiles = sFiles & ";" & sFilename

        '</ add >

    Next

    '----</ @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 Verweise:

Unter vba-Code->Extras->Verweise

Kann man die verfügbaren Verweise auf Microsoft Outlook xx.x Object Library einstellen oder eine passende Version

Und auf Microsoft Office xx.x Object Library für den Datei-Dialog zum Auswählen der Datei-Anhänge