Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1844to1848
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Email-Versand aus Excel

Email-Versand aus Excel
28.08.2021 11:55:30
artcreativity
Hallöchen an Alle, und danke im voraus für die Hilfe,
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

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Email-Versand aus Excel
28.08.2021 12:56:42
ralf_b

If sAddress_To Like "" Then Exit For
nach dem "exit for" gibts nur noch die Fertigmeldung.
vielleicht den Abbruchgrund mittels Variable spezifizieren und die Meldungen nach der Forschleife anhand dieser Variable ausgeben.
AW: Email-Versand aus Excel
28.08.2021 13:51:26
artcreativity
vielen dank für den Hinweis,aber leider reichen jetzt meine Kenntniss nicht aus, kannst du etwas genauer sein?
AW: Email-Versand aus Excel
29.08.2021 12:06:59
ralf_b
Du schreibst du hast dir was zusammengebastelt, aber kannst dann nicht verstehen was die Zeile mit dem "exit for" bedeutet. Echt jetzt?
Ich habe deinen gut funktionierenden Code etwas gepimpt. Ob der Jetzt noch funktioniert kann ich mangels Bespieldatei nicht garantieren.
Du hast dir zwei Codes gesucht und die verbunden. So sehe ich das. Denn es werden Dinge doppelt geprüft.

Public Sub Send_Email2()
Dim iCol_Email_To As Integer, iCol_Email_Cc As Integer, iCol_Email_Bcc As Integer
Dim i As Long
Dim arr
Dim sAttachment_Files_default As String, sAttachment As String, status_send As String
Dim ws     As Worksheet
Set ws = ActiveSheet
sAttachment_Files_default = ActiveWorkbook.Names("varFiles").RefersToRange.Value2
'anderer code begin....
'....anderer Code ende
Set tblEmails = ws.ListObjects("tblEmails")
'Datenfeld für Adressen
arr = Array(Split("Email_To|-1|" & vbNullString, "|"), _
Split("Email_CC|-1|" & vbNullString, "|"), _
Split("Email_Bcc|-1|" & vbNullString, "|"))
'SpaltenNr aus Tabelle für Adressen
On Error Resume Next
For i = 0 To UBound(arr)
arr(i, 1) = tblEmails.ListColumns(arr(i, 0)).Index
If Err  0 Then
MsgBox "Fehler in Tabellenaufbau: Spalte " & arr(i, 0) & " fehlt", vbCritical, "Abbruch"
Exit Sub
End If
Next
On Error GoTo 0
For iRow = 1 To tblEmails.ListRows.Count
For i = 0 To UBound(arr)
'Adresse aus Tabelle
arr(i, 2) = tblEmails.ListRows(iRow).Range.Cells(arr(i, 1)).Value
If Not arr(i, 2) = vbNullString Then
'wenn Adresse vorhanden, dann prüfen
If Not arr(i, 2) Like "*@*.*" Then
'bei Fehler Status setzen
status_send = status_send & arr(i, 0) & " fehlerhaft"
End If
Else
'nur Fehler wenn erste Adresse fehlt wegen optionalen Werten CC, BCC
If i = 0 Then status_send = "Kein " & arr(i, 0)
End If
Next
sAttachment = tblEmails.ListRows(iRow).Range.Cells(iColumn_Anhang).Value
If sAttachment = vbNullString Then sAttachment = sAttachment_Files_default
'Senden nur wenn kein Fehler
If status_send = vbNullString Then
status_send = Send_Email_to_Address(arr, sAttachment)
End If
'status in Tabelle
tblEmails.Range(iRow, 1).Value = status_send
'Zeit in Tabelle
tblEmails.Range(iRow, 2).Value = Now
status_send = ""
Next
MsgBox "Liste ist fertig!", vbInformation, "Ende"
End Sub
Der Aufruf der Function ändert sich auch etwas. Das optional vor sAttachements kann weg. Du gibts sAttachement einen Defaultwert mit. Da du später nicht prüfst ob sAttachement einen Wert hat, sondern gleich nen Split anwendest, gehst du also davon aus das sAttachement immer gefüllt ist. Mal abgesehen davon das die Fehlerbehandlungen weiter unten auch auf einen Anhangfehler abzielen, würde ich das schon vorher prüfen und abfangen.

Public Function Send_Email_to_Address(arrAddress As Variant,  sAttachment As String) As String
'das habe ich auskommentiert, weil die Adresse bereits ausreichend geprüft wurde.
'    If sAddress_To Like "" Then
'        Send_Email_to_Address = "no: [Email_To] ist leer"
'        Exit Function
'    End If
'weiter unten dann wegen des Array
objEmail.To = arrAddress(0, 2)
If Not arrAddress(1, 2) Like "" Then
objEmail.CC = arrAddress(1, 2)
End If
If Not arrAddress(2, 2) Like "" Then
objEmail.BCC = arrAddress(2, 2)
End If

Anzeige
AW: Email-Versand aus Excel
28.08.2021 18:21:00
Firmus
Hi artcreativity,
es ist müssig deine Datei nachzubauen.
Alleine diese NAMES sind zwar verwendet, aber Näheres gibt es nicht dazu. Wie sehen die Werte aus? 1 Wert oder csv? .....?
varFiles
varWordFile
varTitle
varEmail_From
varName_From
varCheck
varEmail_Autosend
Mit einer aussagekräftigen Beispieldatei ist es leichter dich zu unterstützen.
Bevor du diese hochlädst, solltest du dein Problem genauer spezifizieren, z. B.:
- Den Ablauf (die Abfolge der Macros) schrittweise durchgehen (F8)
- Die Variablen kannst du per Überwachung (Brillen-Icon) bei jeder Instruktion ansehen.
(Objekte werden fast in ihrer vollen Schönheit dargestellt (Strukturbaum zum Ansehen)
Deine näheren Erkenntnisse über die Fehlersituation gehört dann in den Post.
Damit hast du eine Change, dass dir jemand mit vernünftigem Zeitaufwand helfen kann.
Gruß,
Firmus
Anzeige
AW: Email-Versand aus Excel
29.08.2021 12:54:01
artcreativity
Hallöchen an Alle,
ich habe die Test datei hochgeladen: https://www.herber.de/bbs/user/147821.xlsm
Dazu dann eine Worddatei mit dem Namen "Text_Email". Muss im gleichen Ordner liegen.
Viele Grüsse
artcreativity
AW: Email-Versand aus Excel
29.08.2021 14:43:38
artcreativity
Hallo Ralf
vielen lieben Dank.
Jetzt zeigt er aber im Sendesatus: nein: Index außerhalb des gültigen Bereichs
Was heisst das denn jetzt?
danke
artcreativity
AW: Email-Versand aus Excel
29.08.2021 16:18:22
Firmus
Hi artcreativity,
Index außerhalb des gültigen Bereichs tritt (mindestens) im Macro Public Sub Send_Email() hier auf:

'Datenfeld für Adressen
arr = Array(Split("Email_To|-1|" & vbNullString, "|"), _
Split("Emails_CC|-1|" & vbNullString, "|"), _
Split("Emails_Bcc|-1|" & vbNullString, "|"))
'SpaltenNr aus Tabelle für Adressen
On Error Resume Next
For i = 0 To UBound(arr)
arr(i)(1) = objLstEmails.ListColumns(arr(i)(0)).Index
If Err  0 Then
arr(i)(1) = -1
MsgBox "Fehler in Tabellenaufbau: Spalte " & arr(i)(0) & " fehlt", vbCritical, "Abbruch"
Exit Sub
End If
Next
On Error GoTo 0
1. Übernahme von Listen in ein Array,
dann beginnt das Array nicht mit "0" sondern mit "1".
Getestet durch Überschreiben im Debug-Mode: Aussage stimmt.
Siehe auch: https://stackoverflow.com/questions/24007320/why-array-index-starts-at-1-when-passing-range-values-to-array
2. Das dynamische Array produzierte auch 0/1-Probleme. Warum, das habe ich nicht verifiziert.
Die Definition Dim arr (87, 16) behob das Problem 'Zeilen=87, Spalten=16 (B11:Q97)
3. On Error Resume Next
Das verschleiert dir deine Fehler, deshalb nur minimalst anwenden.
Besonders in Schleifen (mit Indexierungsfehler) ist das fatal - deine Situation.
Viel Erfolg bei deiner weiteren Analyse.
Gruß,
Firmus
Anzeige
AW: Email-Versand aus Excel
29.08.2021 16:20:32
Firmus
noch offen
AW: Email-Versand aus Excel
30.08.2021 01:29:35
ralf_b
der index Fehler tritt, bei mir, erst in der function auf. Und zwar wenn das Outlook.app Objekt erzeugt wird. Die habe ich nicht zur Verfügung.
Das kleine Array läuft. Und wenn dort ein Fehler auftritt wird eine Messagebox angezeigt.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige