ich möchte aus einer Arbeitsmappe die aus 10 Arbeitsblättern besteht einzelne Blätter versenden. Wie geht das ?
Bin für jede Hilfe dankbar.
MfG Dieter H.
Sub Excel_Serienmail_via_Outlook_Senden()
Dim OutApp As Object, Mail As Object
Dim i As Integer
Dim Nachricht
For i = 1 To 10
'Variablen müssen bei jeder Schleife neu initalisiert werden
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Cells(i, 1)'Adresse
.Subject = Cells(i, 2) 'Betreffzeile
.Body = Cells(i, 3) 'Sendetext
'Hier wird die Mail zuerst angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
'Variablen zurücksetzen sonst geht es nicht
Set OutApp = Nothing 'CreateObject("Outlook.Application")
Set Nachricht = Nothing 'OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub
Sub Excel_Serienmail_mit_mehreren_Anlagen_via_Outlook_Senden()
'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 = 10
'1. Fehlerprüfung
'Prüfen ob alle Inhalte vorhanden sind
'Wenn nicht wird das Makro abgebrochen
For i = 1 To AnzEmpfänger
If Cells(i, 1) = "" Or Cells(i, 2) = "" Or Cells(i, 3) = "" 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 deine Anlagen liegen im
'Bereich F2 : F10
For Y = 2 To 10
'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen
'ohne weitere Fehlerprüfung
If Cells(Y, 6) = "" Then Exit For
If Fs.fileexists(Cells(Y, 6)) = False Then
Msg = MsgBox("Die Datei: " & Cells(Y, 6) & " in F" & Y & " exitstiert nicht !" & vbCrLf & "Der Sendevorgang an; " & Cells(i, 1) & " wird abgebrochen!", vbCritical + vbOKOnly, "Dateifehler")
Exit Sub
End If
Next Y
'Sendevorgang einleiten
For i = 1 To AnzEmpfänger
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Cells(i, 1) '"irgendwer@irgendein-provider.de"
.Subject = Cells(i, 2) '"Betreffzeile Header"
.Body = Cells(i, 3) '"Sendetext"
For Y = 2 To 10
AWS = Cells(Y, 6)
'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:02"))
Next i
End Sub