Freelance Project Requests info@CodeDocu.de Software Development in C# WPF Asp.Net Core Vba Excel Word SQL-Server EF Linq, UWP Net
#

Download:

Datei 1: Demo_51b_Excel_Send_Emails_mit_Placeholders_Subject_Attachements_HTML.xlsm

Excel template for sending emails from a table

 

Version 51a: Sender email isposted e

 

This Excel template creates emails in Outlook using an Excel spreadsheet.

The email addresses are taken from the table row and iterate through the row.

The Text template is in the _Text sheet.

[@Platzhalter]

The subject and template text are appended to the email. Previously, the [@Platzhalter] for the subject and the text are exchanged on each line. In other words, [@Name] will be replaced with Maier.

 

Template text

The text in the _Text sheet is the email template.

The color and formatted text is transferred to the email (which is quite difficult)

 

 

Free version

The current version is free of charge. The free version adds a footnote to the website.

You can change the free version by sending a freeware post via paypal of 20 EUR/USD to unlock.

Freeware Code

If you would like to outsource programming work in vba, C, Web Asp.Net client server or databases or controlling tasks, please contact our company.

 

 

Vba Macro in the Background

 

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

 

 

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

 

 

..

'===================</ Region: Helper-Functions >===================

 

 

 

Mobile
»
Excel template for sending emails from a table, version 51
»
Excel template: Send emails in a list of send field, placeholders, and attachments
»
Series email with optional file attachment
»
E-mails automatically with Excel vSend based on a data list
»
Send serial emails with Excel #39
»
Send emails from Excel with Outlook

.

Contact for Jobs, Project Requests: raimund.popp@microsoft-programmierer.de