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 (­čĹü409)

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