Excel Vorlage zum Versenden mehrer Emails mit verschiedenen Text-Vorlagen pro Zeile

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 String, ByVal sText As String, ByVal sAddress_To As String, ByVal sAddresses_CC As String, ByVal 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 >============

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

Public Function sys_Get_RowValueOf(ByRef intRow As Integer, ByRef sHeader As String) As 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 String) As 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 String) As 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 String) As 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 String) As 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 >============

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

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