VBA Programmierung - Automatischer Email versandt Probleme?
Hallo ich hoffe Ihr könnt mir helfen :/
Folgendes Problem: Wenn ich die Mail versende, öffnen sich für jede Zeile eine extra Email und leider auch nur jeweils ein Empfänger und einer in cc.
Was muss ich nun in der Programmierung hinzufügen, um nur eine Email geöffnet zu bekommen, mit mehreren Empfängern (Falls mehrere Kreuze gesetzt worden sind). Ich danke euch echt wenn Ihr mir helfen können :/
Ich habe mir die Bausteine aus dem Internet zusammengesetzt, bin daher kein Profi darin.
Programmtext:
Private Sub Send_Email()
'-------------< Send_Email() >-------------
Dim sTitle As String
sTitle = "Test-HTML Email from Excel"
'< HMTL holen >
Dim sTemplate As String
sTemplate = Sheets("ini_Vorlage").Shapes(1).TextFrame2.TextRange.Text
'</ HMTL holen >
'----< Send with Outlook >----
Dim app_Outlook As Outlook.Application
Set app_Outlook = New Outlook.Application
'--< Email einstellen >--
Dim objEmail As Outlook.MailItem
Dim sEmail_Addresscc As String
Dim sEmail_Address As String
Dim iRow As Integer
For iRow = 4 To 100
If Cells(iRow, 21) = "x" Then
'< get Email Address >
'Column 2, B
sEmail_Address = Cells(iRow, 19)
sEmail_Addresscc = Cells(iRow, 20)
'</ get Email Address >
'< Fill Placeholders >
Dim sHTML As String
sHTML = Replace(sTemplate, "[@Name]", sEmail_Address)
'</ Fill Placeholders >
'--< Send Email >--
Set objEmail = app_Outlook.CreateItem(olMailItem)
objEmail.To = sEmail_Address
objEmail.CC = sEmail_Addresscc
objEmail.Subject = sTitle
'objEmail.HTMLBody = sHTML 'use .HTMLBody for HTML
objEmail.Body = sHTML 'and .body for pure Text
objEmail.Display
'--</ Send Email >--
End If
Next
'< Abschluss >
Set objEmail = Nothing
Set app_Outlook = Nothing
'</ Abschluss >
MsgBox "Emails erstellt", vbInformation, "Fertig"
'----</ Send with Outlook >----
'-------------</ Send_Email() >-------------
End Sub
2 Antworten
Du verschiebst den Code innerhalb der Schleife, der mit "fill placeholders" beginnt und mit "'--</ Send Email >--" endet, unterhalb der Next-Anweisung.
Oberhalb des "End If" fügst du ein:
Dim recipient As Recipient
Set recipient = oMail.Recipients.Add(sEmail_Address)
recipient.Type = olTo
Set recipient = oMail.Recipients.Add(sEmail_Addresscc)
recipient.Type = olCC
Bei dem verschobenen Code löschst du diese beiden Zeilen:
objEmail.To = sEmail_Address
objEmail.CC = sEmail_Addresscc
- Hinzu käme noch eine Prüfung, falls kein "x" vorhanden ist. Dann müsste gar keine Mail geschickt werden.
- Es sollte berücksichtigt werden, wenn die To und/oder die CC-Spalte leer ist.
- Im Body wird "[@Name]" durch den Empfänger ersetzt. Wenn es aber mehrere Empfänger gibt, welcher Name sollte dann eingetragen werden?
Das ist jetzt aber total "freihand" und mangels Testmöglichkeit auch nur ein Blindflug. Also sorry, wenn's nicht gleich klappt.
Natürlich, mein Fehler. :/
Es muss objEmail heißen, nicht oMail.
Außerdem muss die Zeile
Set objEmail = app_Outlook.CreateItem(olMailItem)
vor die For-Zeile verschoben werden.
Ich danke dir echt vielmals!! es hat geklappt :DD Und nich eine kleine Frage die mich interessiert - Kann ich in den Zeilen bei denen ein x steht ein screenshot mit snipping tool o.ä. machen lassen also alles was links in der Zelle x steht und automatisch dann als Bild in die Email reinkommt?:) ich denke das funktioniert nicht aber wenn doch wäre ich überrascht :D
Passt schon :D Ich habe jedoch das Problem, dass die Email bei mir nicht ankommt, woran könnte das liegen fehlt in der Programmierung evtl etwas ? :)
Also ich sende zwar die Mail aber es kommt bei mir keine Mail an. Wie lautet die Programmzeile wenn die Email auch verschickt werden soll
Hallo Horst, es kommt zwar die Anzeige, dass die Email erstellt worden ist aber ich erhalte leider keine Mail. Die Zeile "objEmail.Send" habe ich rausgelassen, dass ich das Versenden manuell vornehmen möchte. Ich glaube dass mir eine Programmzeile für das versenden der Mail, dass die Mail auch wirklich ankommt, fehlt. ://
Sorry, da steck ich nicht drin. Hab kein Outlook. Falls du selbst Ambitionenen hast:
https://docs.microsoft.com/en-us/office/vba/api/overview/outlook/object-model
Viel Erfolg.
Kannst ja nochmal ne neue Frage bzgl. des letzten Problems stellen.
Hallo Horst, es hat alles wunderbar geklappt !:) Ich habe aber das Problem dass wenn ich doppelte Emailkontakte habe dass die in der Mail Doppelt oder auch dreifach aufgeführt sind :D Wie kann ich das vermeiden
Ich habe ebenfalls schon Outlook ferngesteuert, was aber nicht zwingend nötig ist.
Public Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory _
As String, ByVal nShowCmd As Long) As Long
Public Sub mySendMail(ByVal Address As String, _ ByVal Subject As String, ByVal body As String, _ ByVal CC As String, ByVal BCC As String) Dim strCommand As String strCommand = "" If Len(Subject) Then strCommand = "&Subject=" & Subject If Len(body) Then strCommand = strCommand & "&Body=" & body If Len(CC) Then strCommand = strCommand & "&CC=" & CC If Len(BCC) Then strCommand = strCommand & "&BCC=" & BCC 'strCommand = strCommand & "&attach=" & """" & "c:\temp.txt" & """" If Len(strCommand) Then mailto:rCommand, 1, 1) = "?" End If strCommailto:"mailto:" & Address & strCommand Call ShellExecute(0&, "Open", strCommand, "", "", 1) End Sub
Du hast Übergabe Inhalte in die Funktion:
Address,Subject,body,CC,BCC
die die einzelnen Anteile deiner Mail darstellen. Sorge dafür, dass vor dem Aufruf der Funktion die entsprechenden Information aufbereitet sind und übergeben werden können. Mehrfach Emailadressen mit Semikolon trennen.
Mit der Suche bei Google "VBA Email ShellExecute" findest du komplette Beispiele.
ShellExectute verlässt sich darauf dass ein Email Programm installiert ist. Es würde z.B auch Thunderbird öffnen, um das Ding zu versenden. Ist kein Email Programm installiert, dann verpufft der Aufruf. Es passiert nix.
Hallo Horst danke für deine Antwort :), Ichhabe es so gemacht, wie du es beschrieben hsat jedoch funktioniert es leider nicht und mir wird die Zeile: "Private Sub Send_Email ()" gelb angezeigt, zudem die Zeile "= omail..." ebenso markiert. :/
die To und CC liste ist immer gefüllt, und das mit dem Placeholder ist eigentlich unwichtig bzw kann auch rausgelassen werden. Jedoch klappts nicht :(
Private Sub Send_Email()
'-------------< Send_Email() >-------------
Dim sTitle As String
sTitle = "Test-HTML Email from Excel"
'< HMTL holen >
Dim sTemplate As String
sTemplate = Sheets("ini_Vorlage").Shapes(1).TextFrame2.TextRange.Text
'</ HMTL holen >
'----< Send with Outlook >----
Dim app_Outlook As Outlook.Application
Set app_Outlook = New Outlook.Application
'--< Email einstellen >--
Dim objEmail As Outlook.MailItem
Dim sEmail_Addresscc As String
Dim sEmail_Address As String
Dim iRow As Integer
For iRow = 4 To 100
If Cells(iRow, 21) = "x" Then
'< get Email Address >
'Column 2, B
sEmail_Address = Cells(iRow, 19)
sEmail_Addresscc = Cells(iRow, 20)
'</ get Email Address >
Dim recipient As recipient
Set recipient = omail.Recipients.Add(sEmail_Address)
recipient.Type = olTo
Set recipient = omail.Recipients.Add(sEmail_Addresscc)
recipient.Type = olCC
End If
Next
'< Fill Placeholders >
Dim sHTML As String
sHTML = Replace(sTemplate, "[@Name]", sEmail_Address)
'</ Fill Placeholders >
'--< Send Email >--
Set objEmail = app_Outlook.CreateItem(olMailItem)
objEmail.Subject = sTitle
'objEmail.HTMLBody = sHTML '*use .HTMLBody for HTML
objEmail.Body = sHTML '*and .body for pure Text
objEmail.Display
'--</ Send Email >--
'< Abschluss >
Set objEmail = Nothing
Set app_Outlook = Nothing
'</ Abschluss >
MsgBox "Emails erstellt", vbInformation, "Fertig"
'----</ Send with Outlook >----
'-------------</ Send_Email() >-------------
End Sub