Email-Versand aus Excel
28.08.2021 11:55:30
artcreativity
meine Kenntniss sind nicht so perfekt aber aus meinen vorhandenen VBA habe ich etwas zusammengebastelt, was auch gut klappt.
Leider werden nur die Puplic Function nicht ausgeführt, was mir schon logisch ist, aber ich komme nicht dahinter wie ich es ändern kann. Also er sendet die Emails aber gibt keine Fehlermeldung zurück, weil kein Adresse drin ist z.B.. Ich habe meinen Button ja auch nur
Public Sub Send_Email() als Makro angegeben.
Der Code befindet sich in einem Modul:
Mein Code sieht wie folgt aus:
Option Explicit
Private Const iColumn_Senden As Integer = 2
Private Const iColumn_Anhang As Integer = 5 'Spalte F Anlage
Public tblEmails As ListObject
Public iRow As Integer
Public Sub Send_Email()
Dim sAttachment_Files_default As String
sAttachment_Files_default = ActiveWorkbook.Names("varFiles").RefersToRange.Value2
Dim ws As Worksheet
Set ws = ActiveSheet
Dim sPath As String
sPath = Application.ActiveWorkbook.Path
Dim sWord_Filepath As String
sWord_Filepath = sPath & "\" & ActiveWorkbook.Names("varWordFile").RefersToRange.Value2
Dim app_Word As Object
Set app_Word = CreateObject("Word.Application")
Dim doc As Object
Set doc = CreateObject("Word.Document")
Set doc = app_Word.Documents.Open(sWord_Filepath, ReadOnly:=True, Visible:=False)
doc.Content.Copy
doc.Close SaveChanges:=False
Set tblEmails = ws.ListObjects("tblEmails")
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, ";")
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")
Dim iCol_Email_Bcc As Integer
iCol_Email_Bcc = get_Column("Emails_Bcc")
For iRow = 2 To tblEmails.ListRows.Count
Dim sAddress_To As String
sAddress_To = tblEmails.Range(iRow, iCol_Email_To).Value
If sAddress_To Like "" Then Exit For
Dim sAddresses_CC As String
sAddresses_CC = tblEmails.Range(iRow, iCol_Email_Cc).Value
Dim sAddresses_BCC As String
sAddresses_BCC = tblEmails.Range(iRow, iCol_Email_Bcc).Value
If sAddress_To Like "*@*.*" Then
Dim sAttachment As String
sAttachment = tblEmails.Range(iRow, iColumn_Anhang).Value
If sAttachment Like "" Then sAttachment = sAttachment_Files_default
Dim status_Send As String
status_Send = Send_Email_to_Address(sAddress_To, sAddresses_CC, sAttachment)
tblEmails.Range(iRow, 1).Value = status_Send
tblEmails.Range(iRow, 2).Value = Now
End If
Next
MsgBox "Liste ist fertig!", vbInformation, "Ende"
End Sub
Public Function Send_Email_to_Address(ByVal sAddress_To As String, Optional ByVal sAddresses_CC As String, Optional ByVal sAddresses_BCC As String, Optional sAttachment As String) As String
On Error Resume Next
If sAddress_To Like "" Then
Send_Email_to_Address = "no: [Email_To] ist leer"
Exit Function
End If
Dim sTitle As String
sTitle = ActiveWorkbook.Names("varTitle").RefersToRange.Value2
sTitle = replace_Placeholders(sTitle)
Dim app_Outlook As Object
Set app_Outlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = app_Outlook.CreateItem(0)
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
If Not sEmail_From Like "" Then
Dim objAccount
For Each objAccount In app_Outlook.Session.Accounts
If objAccount.SmtpAddress Like sEmail_From Then
Set objEmail.SendUsingAccount = objAccount
Exit For
End If
Next
End If
objEmail.To = sAddress_To
If Not sAddresses_CC Like "" Then
objEmail.CC = sAddresses_CC
End If
If Not sAddresses_BCC Like "" Then
objEmail.BCC = sAddresses_BCC
End If
objEmail.Subject = sTitle
objEmail.BodyFormat = 2
Dim app_Word As Object
Set app_Word = CreateObject("Word.Application")
Dim doc As Object
Dim objInspector As Object
Dim objSelection As Object
objEmail.Display
Set objInspector = objEmail.GetInspector
If objInspector.EditorType = 4 Then
Set doc = objInspector.WordEditor
Set app_Word = doc.Application
Set objSelection = app_Word.Selection
objSelection.PasteAndFormat 16
End If
Dim sText As String
sText = objEmail.HTMLBody
sText = replace_Placeholders(sText)
objEmail.HTMLBody = sText
Dim arrFiles
arrFiles = Split(sAttachment, ";")
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
If ActiveWorkbook.Names("varCheck").RefersToRange.Value2 Like "" Then
End If
Dim sAutosend As String
sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text
If sAutosend Like "*Send*" Then
objEmail.Display False
objEmail.Send
Else
objEmail.Display True
End If
Set objEmail = Nothing
Set app_Outlook = Nothing
If Err.Number = -2147024809 Then
Send_Email_to_Address = "Senden, aber mit Ihrem Outlook-Standardkonto"
ElseIf Err.Number = -2147024894 Then
MsgBox "Datei-Pfad des Anhangs ist falsch." & vbCrLf & sAttachment, vbCritical, "Fehler beim Senden vom Anhang..."
Send_Email_to_Address = "gesendet, aber ohne Anhang " & sAttachment
ElseIf Err.Number = 440 Or Err.Number = -2147352567 Then
MsgBox "File-Path of Attachment is wrong." & vbCrLf & sAttachment, vbCritical, "Fehler beim Senden vom Anhang..."
Send_Email_to_Address = "gesendet, aber ohne Anhang " & sAttachment
ElseIf Err.Number 0 Then
MsgBox "Fehler bei Email=" & sAddress_To & vbCrLf & Err.Description & vbCrLf & "überprüfe Email-Address " & sAddress_To & vbCrLf & " and Attachment " & sAttachment, vbCritical, Err.Number & " Error on sending.."
Send_Email_to_Address = "nein: " & Err.Description
Else
Send_Email_to_Address = "ok: " & Now
End If
End Function
Private Function get_Column(sFind_Header As String) As Integer
Dim tblEmails As ListObject
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
End Function
Public Sub Select_File()
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
If objFiledialog.SelectedItems().Count = 0 Then
Exit Sub
End If
Dim sFilename As String
Dim sFiles As String
sFiles = ""
Dim iFile As Integer
For iFile = 1 To objFiledialog.SelectedItems.Count
DoEvents
sFilename = objFiledialog.SelectedItems(iFile)
sFilename = Replace(sFilename, ActiveWorkbook.Path & "\", "", 1, 1, vbBinaryCompare)
sFiles = sFiles & ";" & sFilename
Next
sFiles = Replace(sFiles, ";", "", 1, 1, vbBinaryCompare)
ActiveWorkbook.Names("varFiles").RefersToRange.Value2 = sFiles
End Sub
Public Function replace_Placeholders(ByVal sText As String) As String
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)
If Not sPlaceholder Like "" Then
sText = Replace(sText, "[@" & sPlaceholder & "]", sValue, , , vbTextCompare)
End If
Next
replace_Placeholders = sText
End Function