Emailversand an mehrere Teilnehmer

Private Sub CommandButton1_Click()
Dim objOlApp As Outlook.Application
Dim objMailItem As Outlook.MailItem
Dim objMailRecip As Outlook.Recipient
Dim strMailAddress As String, strMailAddrCC As String
Dim strMailAddrBCC As String, strMailSubj As String
Dim strMailBody As String, strMailAttach As String
With ActiveSheet
If IsEmpty(.Cells(ActiveCell.Row, 11).End(xlToLeft)) Then
MsgBox "Bitte wählen Sie einen gültigen " & _
"Tabelleneintrag für den Email-Versand aus.", vbExclamation
Exit Sub
End If
'Die Daten für die Email befinden sich in den Spalten
'A bis K der Zeile mit der aktiven Zelle
'Emailadressen auslesen
'--> hier müsstest Du in einer Schleife alle Emailadressen
'zu einem einzigen String generieren:
strMailAddress = .Range("B" & ActiveCell.Row)
If Not IsEmpty(.Range("C" & ActiveCell.Row)) Then
strMailAddrCC = .Range("C" & ActiveCell.Row)
End If
If Not IsEmpty(.Range("D" & ActiveCell.Row)) Then
strMailAddrBCC = .Range("D" & ActiveCell.Row)
End If
'Betreff der Nachricht auslesen
strMailSubj = .Range("E" & ActiveCell.Row)
'Nachricht generieren
strMailBody = strMailBody & .Range("F" & ActiveCell.Row) & " " & _
.Range("A" & ActiveCell.Row) & "," & vbLf & vbLf
strMailBody = strMailBody & .Range("G" & ActiveCell.Row).Text & "." & _
vbLf & vbLf
strMailBody = strMailBody & .Range("H" & ActiveCell.Row) & " ( " & _
Now & " ) " & vbLf & vbLf
'Abschluss und Absender hinzufügen
strMailBody = strMailBody & .Range("I" & ActiveCell.Row) & vbLf & _
.Range("J" & ActiveCell.Row) & vbLf & vbLf
'Pfad & Dateiname des Anhangs einlesen
strMailAttach = .Range("K" & ActiveCell.Row)
'Objektvariable für Anwendung festlegen
Set objOlApp = CreateObject("Outlook.Application")
On Error GoTo lNoOutlook
If objOlApp Is Nothing Then _
Set objOlApp = CreateObject("Outlook.Application")
'Objektvariable für neues Outlook-Element festlegen
Set objMailItem = objOlApp.CreateItem(olMailItem)
'Tritt beim Erstellen der Email ein Fehler auf, wird
'ein Fehlermeldung angezeigt.
On Error GoTo lNoSend
With objMailItem
'Empfänger der Mail wird in das Adressfeld "An:" geschrieben
Set objMailRecip = .Recipients.Add(strMailAddress)
'2. Empfänger für "Kopie offiziell" kennzeichnen
If strMailAddrCC  "" Then
Set objMailRecip = .Recipients.Add(strMailAddrCC)
objMailRecip.Type = olCC
End If
'3. Empfänger für "Kopie inoffiziell" kennzeichnen
If strMailAddrBCC  "" Then
Set objMailRecip = .Recipients.Add(strMailAddrBCC)
objMailRecip.Type = olBCC
End If
'Betreff der Mail wird in das Feld "Betreff:" geschrieben
objMailItem.Subject = strMailSubj
'Der Text der Nachricht wird übertragen
objMailItem.Body = strMailBody
'Falls ein Anhang mitgesendet wird
If strMailAttach  "" Then
'Positon des Anhangs festlegen
'Einbetten einer Anlage in das Element
'.Attachments.Add Source:=strMailAttach, Type:=olByValue ', _
DisplayName:="Dateianhang"
'Wird DisplayName nicht angegeben, wird der Dateiname
'in der Mail angezeigt. DisplayName kann verwendet werden,
'um dem Anhang eine andere Bezeichnung zu geben.
'Erstellen einer Verknüpfung zu einem Outlook-Element
'z.B. Kontakt-Element
'.Attachments.Add Source:=strMailAttach, Type:=olEmbeddedItem
'Datei von einem Server durch Verknüpfen anhängen
'.Attachments.Add Source:=strMailAttach, Type:=olByReference
'OLE Anhang
'.Attachments.Add Source:=strMailAttach, Type:=olOLE
End If
'Übermittlungsbestätigung anfordern
'.OriginatorDeliveryReportRequested = True
'Lesebestätigung anfordern
'.ReadReceiptRequested = True
'Email in den "Gesendeten Objekten" speichern
'.Save
'Email als TXT-Datei speichern, ohne Pfadangabe wird die Datei
'im Standard-Verzeichnis z.B:
'C:\Programme\Gemeinsame Dateien\System\Mapi\1031\NT gespeichert.
'.SaveAs .Subject & ".txt", olTXT
'Direktes Senden der Email; ohne Onlineverbindung wird
'die Mail im Postausgang abgelegt.
'.Send
'Email-Dialog anzeigen
.Display
'Dialog mit Bindung des Fensters; diese Einstellung ist beim
'Versenden von Mails mit Anhängen nicht empfehlenswert, weil
'während des Versendens keine weitere Makroausführung mögich ist.
'MsgBox "Die Makroausführung wird bis zur Beendigung" & vbLf & _
"von MS Outlook unterbrochen.", vbInformation
'.Display (True)
End With
End With
GoTo lSetObjects
lNoSend:
MsgBox vbTab & "Eine E-Mail an die Adresse " & vbCrLf & vbCrLf & _
vbTab & EmailEmpfänger & vbCrLf & vbCrLf & _
"kann leider NICHT automatisch versendet werden."
GoTo lSetObjects
lNoOutlook:
MsgBox "Microsoft Outlook ist nicht installiert oder es ist kein" & vbLf & _
"Verweis auf die Microsoft Outlook Library gesetzt.", vbCritical
GoTo lSetObjects
lSetObjects:
Set objOlApp = Nothing
Set objMailItem = Nothing
Set objMailRecip = Nothing
End Sub