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 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 >============
|
Vba Modul2: praktische System-Funktionen in vba
Praktische Funktionen zur Verwaltung von Excel zusammengefasst
'============< 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 >============
|
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
|