Hallo M.O.,
das funktioniert toll, vielen Dank!
Kann man die zusätzlich angefügten Kontroll-Adressen aus dem Array löschen, bevor die Kontrolldatei nach dem Versand geschrieben wird?
(das ist aber eher ein kosmetisches Problem).
Bei mir sieht der Code nun so aus:
Sub newsletter()
'Achtung: Für dieses Makro müssen im VBA-Editor unter Extras - Verweise bei Microsoft Outlook XX.0 Object Library entsprechende Haken gesetzt werden
'Sicherheitsabfrage vorab, ob der Newsletter jetzt verschickt werden soll
AntwortStart = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Sollen die E-Mails jetzt verschickt werden?", 20, "Newsletter-Versand")
If AntwortStart = vbNo Then
Exit Sub 'Makro beenden, falls Nein gedrückt wurde
Else
End If
Dim vDB As Variant
Dim lngLZ As Long
Dim lngLS As Long
Dim i As Integer
Dim wbKunden As Workbook
Dim olApp As Object
Dim strBody As String
Dim strBody2 As String
Dim strAnlage As String
Dim Antwort
Dim bNewsletter As Boolean
Dim wbNewsletter As Workbook
Dim strName As String
Dim strDatum As String
Dim strPfad As String
Dim strNeu As String
Dim strNeuName As String
Dim lngZeile As Long
Dim strSubject As String
'Pfad für Newsletter und Protokolldatei festlegen - anpassen
strPfad = "Z:\DB - Daten\"
'Datum für Newsletter- generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
GoTo vorbei
If Day(Now) < 10 Then
strDatum = "0" & Day(Now)
Else
strDatum = Day(Now)
End If
If Month(Now) < 10 Then
strDatum = strDatum & ".0" & Month(Now) & "." & Year(Now)
Else
strDatum = strDatum & "." & Month(Now) & "." & Year(Now)
vorbei:
strDatum = ThisWorkbook.ActiveSheet.Range("F4")
End If
'Name für Newsletter generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
If Month(Now) < 10 Then
strnewsletter = Year(Now) & "-0" & Month(Now)
Else
strnewsletter = Year(Now) & "-" & Month(Now)
End If
If Day(Now) < 10 Then
strnewsletter = strnewsletter & "-0" & Day(Now)
Else
strnewsletter = strnewsletter & "-" & Day(Now)
End If
'Name für Excel-Datei in Variable schreiben
strName = strnewsletter
'Pfad für Newsletter ergänzen und Endung für PDF ergänzen - Pfad anpassen
strnewsletter = strPfad & "Newsletter\" & strnewsletter & ".pdf"
bNewsletter = True 'ein Newsletter wird mit verschickt
'Prüfen, ob Newsletter vorhanden ist
If Dir(strnewsletter) = "" Then
'falls nicht vorhanden, nachfragen, ob trotztdem E-Mail verschickt soll
Antwort = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Der Newsletter-Anhang" & Chr(10) & Chr(10) & strnewsletter & Chr(10) & Chr(10) & "ist nicht vorhanden!" & Chr(10) & Chr(10) & "Sollen die E-Mails trotzdem verschickt werden?", 20, "Kein Newsletter vorhanden!")
If Antwort = vbNo Then
Exit Sub 'Makro beenden, falls Nein gedrückt wurde
Else
bNewsletter = False 'kein Newsletter im Anhang
End If
End If
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Mögliche Nachfragen und Hinweise ausschalten
Application.DisplayAlerts = False
'Datei mit Kundendatenbank öffnen
'Pfad und Name anpassen;
Set wbQuelle = Workbooks.Open(strPfad & "DB - Kunden.xlsm")
'letzte Zeile und Spalte ermitteln
With wbQuelle.Worksheets("Adressen")
lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile in Spalte A ermitteln
lngLS = .UsedRange.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte ermitteln
'zwei feste E-Mail-Adressen und Newsletterversand erwünscht am Ende der Tabelle ergänzen
'E-Mail-Adressen anpassen
.Cells(lngLZ + 1, 10) = "Kontroll@E-Mail"
.Cells(lngLZ + 1, 22) = "j"
.Cells(lngLZ + 2, 10) = "Kontroll@E-Mail"
.Cells(lngLZ + 2, 22) = "j"
lngLZ = .Cells(Rows.Count, 10).End(xlUp).Row 'letzte Zeile in Spalte j neu ermitteln
'Daten in Array einlesen
vDB = .Range(.Cells(1, 1), .Cells(lngLZ, lngLS))
End With
'Datei wieder schließen ohne Änderungen zu speichern
wbQuelle.Close (False)
'Variable zurücksetzen
Set wbQuelle = Nothing
'Mail-Text in Variable einlesen
strBody = ThisWorkbook.ActiveSheet.Range("F8")
'Mail-Text in Variable einlesen ***** Neue Version ****
'Der Body der E-Mail wird aus einzelnen Bausteinen (Anrede, Nachricht, Grußformel, Verfasser, Schlussformel) zusammengesetzt
'Betreff wird definiert
strBody2 = ThisWorkbook.ActiveSheet.Range("F6") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F8") & Chr(10) & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F24")
strBody2 = strBody2 & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F26") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F29")
strSubject = ThisWorkbook.ActiveSheet.Range("F2")
'Outlook definieren
Set olApp = CreateObject("Outlook.Application")
'Datei für Nachverfolgung Versand Newsletter erstellen
Set wbNewsletter = Workbooks.Add
strNeu = wbNewsletter.Name
'Überschriften einfügen
With Workbooks(strNeu).Worksheets(1)
.Range("A1") = "Name"
.Range("B1") = "E-Mail"
.Range("C1") = "Newsletter"
With .Range("A1:C1")
.Font.Bold = True 'Fett
.HorizontalAlignment = xlCenter 'zentriert
End With
End With
'1. Einfügezeile festlegen
lngZeile = 2
'Array ab Zeile 2 durchlaufen (Zeile 1 = Überschriften)
For i = 2 To UBound(vDB, 1)
'prüfen ob Newsletter gewünscht ist, Spalte V
If LCase(vDB(i, 22)) = "j" Then
'prüfen, ob etwas in Spalte V (E-Mail-Adresse) steht
If vDB(i, 10) <> "" Then
'E-Mail generieren
With olApp.CreateItem(0)
strAdresse = vDB(i, 10)
.To = strAdresse 'Empfänger"
.Subject = strSubject & " - " & strDatum 'Betreff
.Body = strBody2 'Nachricht
.ReadReceiptRequested = False 'Lesebestätigung aus
If bNewsletter = True Then .Attachments.Add strnewsletter 'Anhang
'.Display 'Email anzeigen
'und hier wird die Nachricht gesendet
.Send
End With
'Daten in Excel-Tabelle schreiben
With Workbooks(strNeu).Worksheets(1)
.Cells(lngZeile, 1) = vDB(i, 1) 'Name in Spalte A Schreiben
.Cells(lngZeile, 2) = vDB(i, 10) 'E-Mail-Adresse in Spalte B schreiben
If bNewsletter = False Then
.Cells(lngZeile, 3) = "ohne Anhang" 'falls Nachricht ohne Newsletter versandt wurde
Else
.Cells(lngZeile, 3) = strName & ".pdf" 'Nachricht wurde mit Newsletter versandt
End If
End With
'Einfügezeile erhöhen
lngZeile = lngZeile + 1
End If
End If
Next i
Set olApp = Nothing 'zurücksetzen
With Workbooks(strNeu)
With .Worksheets(1)
.Columns("A:C").EntireColumn.AutoFit 'Spaltenbreite in der neuen Excel-Datei anpassen
End With
'Datei speichern
'Zähler festlegen
i = 0
Do
'Zähler erhöhen
i = i + 1
'Zählung anfügen
If i < 10 Then
strNeuName = strPfad & "Newsletter\" & strName & "-0" & i
Else
strNeuName = strPfad & "Newsletter\" & strName & "-" & i
End If
Loop Until Dir(strNeuName & ".xlsx") = ""
'Datei noch nicht vorhanden, daher speichern
.SaveAs Filename:=strNeuName
.Close
End With
'Nachfragen wieder anzeigen
Application.DisplayAlerts = True
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Mein nächster Schritt wäre nun, die Anrede zu personalisieren, sofern in den Spalten H und I entsprechende Eintragungen vorhanden sind.
(in Spalte H findet sich "Herr" oder "Frau" und in Spalte I der Nachname). So ergäben sich 3 unterschiedliche Ansprachen (Sehr geehrte Frau, Sehr geehreter Herr, oder eben allgemein), die beim Einlesen des Mail-Textes berücksichtigt werden könnten.
Ich habe allerdings die Befürchtung, dass das ein gänzlich anderer Code wäre, bei dem der E-Mail-Test für jede E-Mail eiinzeln zusammengesetzt werden müsste, oder?
Grüße
Peter
