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 mehrer Emails mit verschiedenen Text-Vorlagen pro Zeile

14.09.2018 (👁22640)

Files Download unter: https://codedocu.de/Details?d=2637&a=8&f=413&l=0

Aufgabe:

Es sollen pro Zeile Emails an verschiedene Abteilungen oder Mitarbeiter versand werden.

Die Vorlage kann zum Beispiel verwendet werden, wenn wie in einer Checkliste mehrere Aufgaben zum Beginn einer Tätigkeit ausgeführt und per email an die jeweilige Sachbearbeiter gesendet werden.

 

Ablauf Eingabeformular:

Mit einem speziellen Excel-Addin können die Sachbearbeiter die Datei automatisch im Loop versenden lassen. Für den Ablauf der Eingabe kann das Formular gesperrt werden, sodass nur noch in den einzelnen grünen Eingabezellen spezielle Texte eingegeben werden können.

_Setup

Im Setup-Excel Blatt kann man den Basispfad für Dateianhänge definieren.

Zudem kann man festlegen, ob Emails automatisch oder manuell gesendet werden sollen.

_Text-Vorlage-Blätter

Unter den einzelnen _Text-Vorlage Blättern werden die jeweiligen Texte zur Zeile angezogen.

Hier können [@Platzhalter] zur laufzeit im Text geändert werden.

Die Excel Text-Vorlage Blätter beginnen mit einem Unterstrich im Blattnamen und werden mit dem Addin-Befehl: Lock ausgeblendet.

Emails versendet

Wen auf den Button Emails senden geklickt wird, dann läuft das Programm jede Zeile durch und versendet automatisch Emails an die entsprechenden Sachbearbeiter oder Abteilungen.

Bei technischen Fehlern wie einem nicht vordenen Anhang oder technisch falschen Email-Adressen gibt Excel eine Fehlermeldung aus.

Die Emails werden im RTF RichTextEdit Format versendet. Es können also die meisten farblichen Text-Formatierungen angewandt werden.

 

Vba Makro Code

Der Makro-vba Code befindet sich rein im Addin. Dadurch kann das Template einfach weitergegeben werden und nur die zentralen Stellen können über das Excel Add-In  die Lock und Unlock Befehle aufrufen.

Vba Code für Emails Senden

Zudem wird hier der Aufruf von Email senden verarbeitet.

Dabei werden alle Zeilen durchlaufen und auf Ja/Nein überprüft. Anschliessend werden aus den entsprechenden Spalten anhand der Überschrift im Header die Zeilen-Werte geholt.

Option Explicit On

 

'============< variables >============

Public Const °const_Password As String = "CodeDocu"

Public Const °Setup_Columns As String = "F:I"

 

Public Const °Input_Sheetname As String = "Checkliste"

Public Const °column_Check As String = "Ja/Nein"

Public Const °column_Senden As String = "Senden"

Public Const °column_Email As String = "EMail"

Public Const °column_CC As String = "CC"

Public Const °column_Anhang As String = "Anhang_Dokument"

Public Const °column_Vorlage As String = "Vorlage"

 

Public Const °Replaces As String = "Mitarbeitername;ID;Kreditlimit"

 

Public Const °CheckString1 As String = "Ja"

Public Const °CheckString2 As String = "x"

'============</ variables >============

 

 

'============< Menu >============

Public Sub Menu_Emails_senden()

    Check_Email_Loop()

End Sub

 

 

'============< Emails >============

Public Sub Check_Email_Loop()

    '-------------< Check_Email_Loop() >-------------

    '< find_Range_To_Check >

    Dim range_Check As Range

    Set range_Check = sys_Get_Check_Range(°column_Senden)

    '</ find_Range_To_Check >

    

    '----< @Loop: Range_to_Check >----

    Dim varCell As Range

    For Each varCell In range_Check.Cells

        If varCell.Value = °CheckString1 Then

            '< get_Column_Send >

            Dim sSenden As String

            sSenden = sys_Get_RowValueOf(varCell.Row, °column_Senden)

            '< get_Column_Send >

 

            If sSenden = °CheckString2 Then

                '< Create_Email >

                Create_Email_by_RowNr varCell.Row

                '</ Create_Email >

            End If

        End If

    Next

    '----</ @Loop: Range_to_Check >----

 

    '< Abschluss >

    MsgBox "Emails erstellt", vbInformation, "Fertig"

    '</ Abschluss >

    '-------------</ Check_Email_Loop() >-------------

End Sub

 

 

Private Sub Create_Email_by_RowNr(ByVal intRow As Integer)

    '-------------< Create_Email_by_RowNr() >-------------

 

    '< Werte >

    Dim sAddress_To As String

    sAddress_To = sys_Get_RowValueOf(intRow, °column_Email)

    '< check >

    If sAddress_To Like "" Then

        MsgBox "Email Ziel-Adresse fehlt in Zeile " & intRow, vbCritical, "Setup in Liste unvollständig"

        Exit Sub

    End If

    '</ check >

 

 

    Dim sAddresses_CC As String

    sAddresses_CC = sys_Get_RowValueOf(intRow, °column_CC)

 

    Dim sAttachement As String

    sAttachement = sys_Get_RowValueOf(intRow, °column_Anhang)

    '</ Werte >

 

    '--< TemplateSheet_Values >--

    '< TemplateSheet >

    Dim sTemplateSheet As String

    sTemplateSheet = sys_Get_RowValueOf(intRow, °column_Vorlage)

    '< check >

    If sTemplateSheet Like "" Then

        MsgBox "_Vorlage nicht eingetragen in Zeile " & intRow, vbCritical, "Setup in Liste unvollständig"

        Exit Sub

    End If

    '</ check >

 

    Dim wsTemplateSheet As Worksheet

    Set wsTemplateSheet = ActiveWorkbook.Worksheets(sTemplateSheet)

    '</ TemplateSheet >

    

    Dim sTitle As String

    sTitle = wsTemplateSheet.Range("B2").Value

 

    '< Text_Template >

    Dim varText_Template As Shape

    Set varText_Template = wsTemplateSheet.Shapes(1)

    

    Dim sText As String

    sText = varText_Template.TextFrame2.TextRange.Text

    '</ Text_Template >

    '--</ TemplateSheet_Values >--

 

 

    Dim arrReplaces

    arrReplaces = Split(°Replaces, ";")

 

    Dim varWord As Variant

    For Each varWord In arrReplaces

        If Not IsNull(varWord) Then

            Dim sWord As String

            sWord = CStr(varWord)

            If Not sWord Like "" Then

                Dim sPlaceholder As String

                sPlaceholder = "[@" & sWord & "]"

 

                Dim sReplace

                sReplace = ActiveWorkbook.Names("var" & sWord).RefersToRange.Text

 

                sText = Replace(sText, sPlaceholder, sReplace, , , vbTextCompare)

                sTitle = Replace(sTitle, sPlaceholder, sReplace, , , vbTextCompare)

            End If

        End If

    Next

 

    '--< Send Email >--

    Send_Email sTitle, sText, sAddress_To, sAddresses_CC, sAttachement

    '--</ Send Email >--

    '-------------< Create_Email_by_RowNr() >-------------

End Sub

 

Public Sub Send_Email(ByVal sTitle As StringByVal sText As StringByVal sAddress_To As StringByVal sAddresses_CC As StringByVal sAttachements As String)

    '-------------< Send_Email() >-------------

    '< init >

    On Error Resume Next

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

        '        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

    If Not sAttachements Like "" Then

        If Not sAttachements Like "*:*" Then

            Dim sBasePath As String

            sBasePath = ActiveWorkbook.Names("varPfad_Email_Attachement").RefersToRange.Text

            If Not sBasePath Like "*\" Then

                sBasePath = sBasePath & "\"

            End If

            sAttachements = sBasePath & sAttachements

        End If

        objEmail.Attachments.Add sAttachements

    End If

 

 

    '< send >

    Dim sAutosend As String

    sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text

    If sAutosend = "Ja" 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

        MsgBox Err.Description & vbCrLf & "Eventuell Email-Adresse anpassen", vbCritical, "Error on sending.."

    End If

 

    '-------------</ Send_Email() >-------------

End Sub

 

'============</ Emails >============

 

Vba Modul2: praktische System-Funktionen in vba

Praktische Funktionen zur Verwaltung von Excel zusammengefasst

'============< Setup >============

Public Function sys_Get_RowValueOf(ByRef intRow As IntegerByRef sHeader As StringAs String

    '-------------< sys_Get_RowValueOf() >-------------

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

    

    Dim cell_Check As Range

    Set cell_Check = sys_Get_Cell_by_Header(sHeader)

    

    Dim intCol As Integer

    intCol = cell_Check.Column

 

    '< find_Range_To_Check >

    Dim varCell As Range

    Set varCell = ws.Cells(intRow, intCol)

    '</ find_Range_To_Check >

    

    Dim sReturn As String

    sReturn = varCell.Value

 

    '< return >

    sys_Get_RowValueOf = sReturn

    '</ return >

    '-------------</ sys_Get_RowValueOf() >-------------

End Function

 

 

 

Public Function sys_Get_Check_Range(ByRef sHeader As StringAs Range

    '-------------< sys_Get_Check_Range() >-------------

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

    

    Dim cell_Check As Range

    Set cell_Check = sys_Get_Cell_by_Header(°column_Check)

    

    Dim col_Check As Integer

    col_Check = cell_Check.Column

 

    Dim row_Header As Integer

    row_Header = cell_Check.Row

 

    Dim intMax_Rows As Integer

    intMax_Rows = sys_Get_UsedRange_Rows()

 

    '< find_Range_To_Check >

    Dim varRange As Range

    Set varRange = ws.Range(ws.Cells(row_Header + 1, col_Check), ws.Cells(intMax_Rows, col_Check))

    '</ find_Range_To_Check >

    

    '< return >

    Set sys_Get_Check_Range = varRange

    '</ return >

    '-------------</ sys_Get_Check_Range() >-------------

End Function

 

Public Function sys_Get_Cell_by_Header(ByRef sHeader As StringAs Range

    '-------------< sys_Get_Range_by_Header() >-------------

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

    Dim cell_Return As Range

    Set cell_Return = Nothing

    

    Dim cell As Range

    For Each cell In ws.UsedRange.Cells

        If cell.Value Like sHeader Then

            Set cell_Return = cell

            Exit For

        End If

    Next

    

    '< return >

    Set sys_Get_Cell_by_Header = cell_Return

    '</ return >

    '-------------</ sys_Get_Cell_by_Header() >-------------

End Function

'============</ Setup >============

 

 

 

 

'============< System >============

Public Function sys_Get_Excel_Name_Variable(ByRef sVariable_Name As StringAs Name

    '-------------< sys_Get_Excel_Name_Variable() >-------------

    Dim wb As Workbook

    Set wb = ActiveWorkbook

    

    '< check Name_Variable>

    Dim varName As Name

    Set varName = Nothing

    For Each varName In wb.Names

        If varName.Name Like sVariable_Name Then

            Exit For

        End If

    Next

    '</ check Name_Variable>

    

    '< return >

    Set sys_Get_Excel_Name_Variable = varName

    '</ return >

    '-------------</ sys_Get_Excel_Name_Variable() >-------------

End Function

 

Public Function sys_Get_Excel_NameValue(ByRef sVariable_Name As StringAs String

    '-------------< sys_Get_Excel_NameValue() >-------------

    Dim sReturn As String

    Dim varName As Name

    Set varName = sys_Get_Excel_Name_Variable(sVariable_Name)

    If Not varName Is Nothing Then

        sReturn = Range(varName.Value)

    End If

 

    '< return >

    sys_Get_Excel_NameValue = sReturn

    '</ return >

    '-------------</ sys_Get_Excel_NameValue() >-------------

End Function

 

 

 

Public Function sys_Get_UsedRange_Rows() As Integer

    '-------------< sys_Get_Check_Range() >-------------

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

    

    Dim intRowsMax As Integer

    intRowsMax = 0

 

    Dim varCell As Range

 

    For Each varCell In ws.UsedRange

        If varCell.Row > intRowsMax Then

            intRowsMax = varCell.Row

        End If

    Next

 

    '< return >

    sys_Get_UsedRange_Rows = intRowsMax

    '</ return >

    '-------------</ sys_Get_Check_Range() >-------------

End Function

'============</ System >============

 

 

Vba Modul3: Ribbonbar Funktionen

Für die Ribbonbar Emails Senden

Aufruf über klassisches Addin

Public Sub Menu_Lock()

    '--------< Menu_Lock() >--------

    Hide_Setup_Columns()

    hide_all_System_Worksheets()

    Protect_Worksheets()

    '--------</ Menu_Lock() >--------

End Sub

 

Public Sub Menu_Unlock()

    '--------< Sys_Unlock() >--------

    '*show: show all hidden and very hidden files

    show_all_Worksheets()

    Unprotect_Worksheets()

    Show_Setup_Columns()

    '--------</ Einblenden() >--------

End Sub

'============</ Menu >============

 

 

 

'============< Functions >============

Public Sub hide_all_System_Worksheets()

    '--------< hide_all_System_Worksheets() >--------

    '*hide all worksheets where name starts with _

    '*hide: very hidden

    Dim wb As Workbook

    Set wb = ActiveWorkbook

    Dim ws As Worksheet

    For Each ws In wb.Sheets

        If ws.Name Like "_*" Then

            ws.visible = xlSheetVeryHidden

        End If

    Next

    '--------</ hide_all_System_Worksheets() >--------

End Sub

 

Public Sub show_all_Worksheets()

    '--------< show_all_Worksheets() >--------

    '*show: show all hidden and very hidden files

    Dim wb As Workbook

    Set wb = ActiveWorkbook

    Dim ws As Worksheet

    For Each ws In wb.Sheets

        If ws.Name Like "_*" Then

            ws.visible = xlSheetVisible

        End If

    Next

    '--------</ show_all_Worksheets() >--------

End Sub

 

Public Sub Protect_Worksheets()

    '--------< Protect_Worksheets() >--------

    '*hide all worksheets where name starts with _

    '*hide: very hidden

    On Error Resume Next

 

    Dim wb As Workbook

    Set wb = ActiveWorkbook

    Dim ws As Worksheet

    For Each ws In wb.Sheets

        If ws.visible = xlSheetVisible Then

            '*protect all visible worksheets

            ws.Protect °const_Password

        End If

    Next

    '--------</ Protect_Worksheets() >--------

End Sub

 

Public Sub Unprotect_Worksheets()

    '--------< Unprotect_Worksheets() >--------

    'unprotect all worksheets

    On Error Resume Next

 

    Dim wb As Workbook

    Set wb = ActiveWorkbook

    Dim ws As Worksheet

    For Each ws In wb.Sheets

        If ws.visible = xlSheetVisible Then

            '*protect all visible worksheets

            ws.Unprotect °const_Password

        End If

    Next

    '--------</ Unprotect_Worksheets() >--------

End Sub

 

 

Public Sub Hide_Setup_Columns()

    '--------< Hide_Setup_Columns() >--------

    'Hide Setup Columns

    On Error Resume Next

    If Not °Setup_Columns Like "" Then

        Dim ws As Worksheet

        Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

        ws.Range(°Setup_Columns).EntireColumn.Hidden = True

    End If

    '--------</ Hide_Setup_Columns() >--------

End Sub

 

Public Sub Show_Setup_Columns()

    '--------< Show_Setup_Columns() >--------

    'Hide Setup Columns

    On Error Resume Next

    If Not °Setup_Columns Like "" Then

        Dim ws As Worksheet

        Set ws = ActiveWorkbook.Worksheets(°Input_Sheetname)

        ws.Range(°Setup_Columns).EntireColumn.Hidden = False

    End If

    '--------</ Show_Setup_Columns() >--------

End Sub

'============</ Functions >============

 

 

 

Vba Code: Excel Addin

Installation der Ribbonbar und Buttons und Ribbonbar laden

Option Explicit On

 

Private Const MenuName As String = "CodeDocu_Emails"

 

'======< Workbook >======

 

Private Sub Workbook_AddinInstall()

    Create_Ribbonbar_Addin_Button()

End Sub

Private Sub Workbook_Open()

    Create_Ribbonbar_Addin_Button()

End Sub

'======</ Workbook >======

 

 

Private Sub Create_Ribbonbar_Addin_Button()

    '------------< Create_Ribbonbar_Addin_Button() >------------

    '-< Set Ribbonbar_Addin >-

    On Error Resume Next

    Application.CommandBars(MenuName).Delete

    On Error GoTo 0

    Dim addin_Menu As CommandBar

    Set addin_Menu = Application.CommandBars.Add(MenuName, msoBarTop)

    addin_Menu.visible = True

    '-</ Set Ribbonbar_Addin >-

 

    '-< create button >-

    Dim btn As CommandBarButton

    Set btn = addin_Menu.Controls.Add(Type:=msoControlButton)

    btn.Caption = "Emails senden.."

    btn.OnAction = "Menu_Emails_senden"

    btn.FaceId = 5622

    btn.Style = msoButtonIconAndCaptionBelow

    '-</ create button >-

    

    '-< btn: Ausblenden >-

    Set btn = addin_Menu.Controls.Add(Type:=msoControlButton)

    btn.Caption = "Lock"

    btn.OnAction = "Menu_Lock"

    btn.FaceId = 2173

    btn.Style = msoButtonIconAndCaptionBelow

    '-</ btn: Ausblenden >-

    

    '-< btn: Ausblenden >-

    Set btn = addin_Menu.Controls.Add(Type:=msoControlButton)

    btn.Caption = "UnLock"

    btn.OnAction = "Menu_Unlock"

    btn.FaceId = 2174

    btn.Style = msoButtonIconAndCaptionBelow

    '-</ btn: Ausblenden >-

 

    '------------</ Create_Ribbonbar_Addin_Button() >------------

End Sub