Description:
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.
features:
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
download:
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 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 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