Excel Vorlage zum Versenden von Emails aus einer Tabelle
Version 51a: Absender-Email wird eingestellt
Diese Excel Vorlage erstellt Emails in Outlook anhand einer Excel Tabelle.
Dabei werden die Email Adressen aus der Tabellen-Zeile entnommen und die Zeile durchlaufen.
Der Vorlagen Text befindet sich in dem Blatt _Text.
[@Platzhalter]
Der Betreff und der Vorlagen-Text wird in die Email angefügt. Zuvor werden in jeder Zeile die [@Platzhalter] für den Betreff und den Text ausgetauscht. Das heißt, [@Name] wird mit Maier ersetzt.
Vorlagen-Text
Der Text in dem Blatt _Text ist die Email-Vorlage.
Dabei wird der farbliche und formatierte Text in die Email übernommen (was schon ziemlich schwierig ist)
Kostenlose Version
Die aktuelle Version ist kostenlos. Bei der kostenlosen Version wird eine Fußnote angefügt zur Webseite.
Man kann die kostenlose Version ändern, indem man per paypal einen Freeware-Beitrag sendet zum freischalten.
Wer gerne Programmierarbeiten in vba, C#, Web Asp.Net Client Server oder Datenbanken oder Controlling Aufgaben auslagern möchte, der kann sich gerne an unsere Firma wenden.
Vba Makro im Hintergrund
Makro Code vba
Option Explicit On
Private Const iColumn_Senden As Integer = 2 Private Const iColumn_Anhang As Integer = 5
'===================< Region: Email >===================
Public Sub Send_Email() '-------------< Send_Email() >------------- '*Runs trough List and creates single Emails '-< init >- '*Eingabe Felder Blatt-Header Dim sSubject0 As String sSubject0 = 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
'------< RTF in HTML umwandeln >-------- Dim sHTML As String 'sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text 'Dim iLenHTML As Long 'iLenHTML = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Length sHTML = "" Dim bChange As Boolean
Dim intColor As Long intColor = 0 Dim intRed As Long, intGreen As Long, intBlue As Long
Dim sFontName As String sFontName = "" Dim sFontSize As String sFontSize = "" Dim sUnderline As String sUnderline = ""
Dim bBold As Integer bBold = 0
'------< @Loop: Characters >------ Dim varChar For Each varChar In Sheets("_Text").Shapes("TextBox 3").TextFrame2.TextRange.Characters '----< Character >---- bChange = False
'< get Character > Dim char_Text As String char_Text = varChar.Text
Dim char_FontName As String char_FontName = varChar.Font.Name
Dim char_FontSize As String char_FontSize = varChar.Font.Size
Dim char_Underline As String char_Underline = varChar.Font.UnderlineStyle
Dim char_RGB As Long char_RGB = varChar.Font.Fill.ForeColor.RGB
Dim char_Bold As Integer char_Bold = varChar.Font.Bold '</ get Character >
'< Font > If Not sFontName Like char_FontName Then bChange = True sFontName = char_FontName End If '</ Font >
'< FontSize > If Not sFontSize Like char_FontSize Then bChange = True sFontSize = char_FontSize End If '</ FontSize >
'< Underline > If Not sUnderline Like char_Underline Then bChange = True sUnderline = char_Underline End If '</ Underline >
'< Color > If Not intColor Like char_RGB Then bChange = True intColor = char_RGB intRed = (intColor And &HFF) \ 256 ^ 0 ' &HFF hexadecimal = 255 decimal intGreen = (intColor And &HFF00&) \ 256 ^ 1 ' &HFF00& hexadecimal = 65280 decimal intBlue = intColor \ 256 ^ 2 End If '</ Color >
'< Bold > If Not bBold Like char_Bold Then bChange = True bBold = char_Bold End If '</ Bold >
'< Korrekturen > char_Text = Replace(char_Text, vbCrLf, "<br>") char_Text = Replace(char_Text, vbLf, "<br>")
'</ Korrekturen > '< Formatierung HTML > If bChange Then sHTML = sHTML & "</span>" sHTML = sHTML & vbCrLf & "<span style=""" sHTML = sHTML & " font-family:" & sFontName & ";" sHTML = sHTML & " font-size:" & sFontSize & "pt;" If Not sUnderline Like "0" Then sHTML = sHTML & " text-decoration:underline;" End If sHTML = sHTML & " color:rgb(" & intRed & "," & intGreen & "," & intBlue & ") ;" If bBold <> 0 Then sHTML = sHTML & " font-weight:font-weight: bold;" Else sHTML = sHTML & " font-weight:font-weight: normal;" End If sHTML = sHTML & """>" End If '</ Formatierung HTML >
'< Text_anfuegen > sHTML = sHTML & char_Text '</ Text_anfuegen > '----</ Character >---- Next '------</ @Loop: Characters >------ '< Korrektur > sHTML = sHTML & "</span>" '</ Korrektur >
'sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Text '(1, iLenHTML) 'sTemplate = Sheets("_Text").Shapes(1).TextFrame.Text 'sHTML = "<html><body>" & vbCrLf & sHTML & vbCrLf & "</body></htmll>" '</ Text > '------</ RTF in HTML umwandeln >-------- 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 >---- '*bei Verwendung von Outlook 'Dim app_Outlook As Outlook.Application 'Set app_Outlook = New Outlook.Application 'Dim objEmail As Outlook.MailItem
'<# Optional: Late-Binding > '*bei Verwendung von anderen Email-Programmen '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 '----< Row >---- Dim xSenden As String xSenden = tblEmails.Range(iRow, iColumn_Senden).Value If xSenden Like "X" Then '---< Senden >--- '< 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 = sHTML '*VorlageText aus _Text Dim sTitle As String sTitle = sSubject0 '*Titel aus Zelle C2
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) sTitle = Replace(sTitle, "[@" & sPlaceholder & "]", sValue, , , vbTextCompare) End If '</ replace > Next '-</ Replace All Placeholders >-
'< get_optional_Attachements > Dim sAttachment As String sAttachment = tblEmails.Range(iRow, iColumn_Anhang).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, sAttachment) '<</ send >>
'*show dtSend or error tblEmails.Range(iRow, 1).Value = status_Send '--</ Send Email >--
'----</ Email_To is OK >---- End If '---< Senden >--- 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 > '*Ohne Verweis,Outlook versionsunabhaengig, Late Binding Dim app_Outlook As Object Set app_Outlook = CreateObject("Outlook.Application") Dim objEmail As Object Set objEmail = app_Outlook.CreateItem(0)
'*Mit Verweis, bei Verwendung von Outlook mit Verweis Early Binding 'Dim app_Outlook As Outlook.Application 'Set app_Outlook = New Outlook.Application 'Dim objEmail As MailItem 'Set objEmail = app_Outlook.CreateItem(olMailItem)
'</ outlook >
'--< Send Email >--
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.BodyFormat = 2 '* 1=Text olFormatPlain, 2=olFormatHTML, 3=olFormatRichText objEmail.HTMLBody = sText '*.HTMLBody for HTML
'-< Attach Files >- Dim arrFiles arrFiles = Split(sAttachment, ";") 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 True '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 = 440 Or Err.Number = -2147352567 Then '< error > MsgBox "File-Path of Attachment is wrong." & vbCrLf & sAttachment, vbCritical, "Error on sending Attachement.." Send_Email_to_Address = "no: " & Err.Description '</ error > ElseIf Err.Number <> 0 Then '< error > MsgBox "Error on Email=" & sAddress_To & vbCrLf & Err.Description & vbCrLf & "Check Syntax of Email-Address " & sAddress_To & vbCrLf & " and Attachment " & sAttachment, vbCritical, Err.Number & " 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 >===================
|