Serienmail - generell CC - Empfänger ergänzen
04.03.2009 21:18:10
Stefan
ich erstelle mittels eines VBA-Codes ein Serienmail an verschiedenen Empfänger
(der Ursprungscode kommt von Ramses :) )
Dabei steht in Spalte jeweils ab Zeile 2
A = email soll verschickt werden x = ja Leer = Nicht verschicken
B = email-Adresse des Empfängers
C = Betreff-Text individuell
D = Mail-Text individuell
E = Protokollierung Wann von Wem die Mail verschickt wurde
F = Leer-Spalte
G = Datei-Link als Anlage
Was ist erreichen möchte
jedes Mail soll generell an eine bestimme email-Adresse als CC geschickt werden
Wie muss ich den Code anpassen, daß bei jeder Mail eine bestimmte email-Adresse ein CC erhält
mein Versuch mit
.cc = "xxx@yyy.de" als Mailempfänger nach der zeile
___ .To = Cells(i, 2) '"irgendwer@irgendein-provider.de" SPALTE B
funktioniert leider nicht
Kann mir jemand weiterhelfen ?
Freu mich auf eine Antwort
Besten Gruß
Stefan
hier der Code:
Sub Excel_Serienmail_mit_mehreren_Anlagen_mit_Fehlermeldung_via_Outlook_Senden()
' von RAMSES 14.01.2003
'jeweils ab Zeile 2
'Spalte A = x oder leer (x wenn email verschickt werden soll
'Spalte B = Empfängeremail-Adresse
'Spalte C = Betrefftext je Empfänger
'Spalte D = Mailtext je Empfänger
'Spalte E = nach Versand Eintrag von Datum/Uhrzeit NT-Username und Computername
'Spalte F = Leer
'Spalte G = Verzeichnis+Dateiname (Max 10 Anlagen)
'Variablendefinition
Dim fs As Object, F As Object
Dim OutApp As Object, mail As Object
Dim i As Integer, y As Integer, Msg As Integer
Dim Nachricht As Variant
Dim AWS As String
Dim AnzEmpfänger As Integer
'Variablen füllen
'Filesystemobjekt erstellen
Set fs = CreateObject("Scripting.FileSystemObject")
'Hier die Anzahl Empfänger definieren
AnzEmpfänger = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'1. Fehlerprüfung
'Prüfen ob alle Inhalte vorhanden sind
'Wenn nicht wird das Makro abgebrochen
For i = 2 To AnzEmpfänger
If Cells(i, 2) = "" Then
Msg = MsgBox("Unvollständige Angaben beim Empfänger in Zeile " & i, vbCritical + _
vbOKOnly, "Abbruch")
Exit Sub
End If
Next i
'2. Fehlerprüfung
'Mit dem FilesystemObjekt wird zuerst die Existenz der Dateien geprüft. '
'Wenn eine nicht existiert wird das Makro abgebrochen
'Die Links auf die Anlagen liegen im Bereich G2 : G11
For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen
'ohne weitere Fehlerprüfung
If Cells(y, 7) = "" Then Exit For
If fs.fileexists(Cells(y, 7)) = False Then
Msg = MsgBox("Die Datei: " & Cells(y, 7) & " in G" & y & " exitstiert nicht !" & _
vbCrLf & "Der Sendevorgang an; " & Cells(i, 2) & " wird abgebrochen!", vbCritical + vbOKOnly, "Dateifehler")
Exit Sub
End If
Next y
'Sendevorgang einleiten
For i = 2 To AnzEmpfänger
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
On Error GoTo next_email
'Hier wird die zelle i in Spalte A auf den Wert X geprüft
'UCASE deshalb um Schreibfehler von Gross und klein zu vermeiden
If UCase(Cells(i, 1).Value) = "X" Then
'Trifft die Bedingung X zu wird der Mailversand eingeleitet
With Nachricht
.To = Cells(i, 2) '"irgendwer@irgendein-provider.de" SPALTE B
.Subject = Cells(i, 3) '"Betreffzeile Header" SPALTE C
.Body = Cells(i, 4) '"Sendetext" SPALTE D
'For y = 2 To 11
For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
AWS = Cells(y, 7)
'Wenn die Zelle / Variable leer ist wird diese Schleife abgebrochen
If AWS = "" Then Exit For
.Attachments.Add AWS
Next y
'Hier wird die Mail zuerst angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
'Variablen zurücksetzen
Set OutApp = Nothing 'CreateObject("Outlook.Application")
Set Nachricht = Nothing 'OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:01"))
'versanddatum /-uhrzeit /-userid und computername in spalte e eintragen
Worksheets(ActiveSheet.Name).Cells(i, 5).Value = Date & " / " & Time & _
" / " & Environ("username") & " " & Environ("computername")
next_email:
End If
'Bedingung abgeschlossen
Next i
End Sub