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 (­čĹü505)


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