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 String, ByVal sTitle As String, ByVal sText As String, ByVal sAddresses_CC As String) As 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 String) As 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