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

Excel Vorlage zum Versenden von Emails aus einer Tabelle

17.03.2020 (👁22474)

Excel Vorlage zum Versenden von Emails aus einer Tabelle

Version 50c

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)

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 >===================