Aus der
Vorlage 46
In the sheet _ text you can enter a free text
and provide it with [@Platzhaltern].
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 >
Dim sAttachment_Files_default As String sAttachment_Files_default = ActiveWorkbook.Names("varFiles").RefersToRange.Value2 '-</ 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 >
'< check_end > If sAddress_To Like "" Then Exit For '</ check_end >
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) sPlaceholder = Trim(sPlaceholder) Dim sValue As String sValue = tblEmails.Range(iRow, iCol) sValue = Trim(sValue) '< replace > If Not sPlaceholder Like "" Then sText = Replace(sText, "[@" & sPlaceholder & "]", sValue, , , vbTextCompare) End If '</ replace > Next '-</ Replace All Placeholders >-
'< get_optional_Attachements > Dim sAttachment As String sAttachment = tblEmails.Range("E" & iRow).Value If sAttachment Like "" Then sAttachment = sAttachment_Files_default '</ get_optional_Attachements >
'--< Send Email >-- Dim status_Send As String '?date '<< send >> status_Send = Send_Email_to_Address(sAddress_To, sTitle, sText, sAddresses_CC, Attachement) '<</ 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 "Outlook hat die Mails versand!", 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, Optional ByVal sAddresses_CC As String, Optional sAttachment 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 >
'--< 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 >===================
|
Subject serial emails, vba macro Excel
template
The file is available for download on the
website