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

Vba Code zum seienmässigen Versenden von Emails aus Excel

27.01.2019 (👁1296)


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 StringByVal sTitle As StringByVal sText As String

Optional ByVal sAddresses_CC As StringOptional sAttachment As StringAs 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 StringAs 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