SEND SIMULTANTEOUS EMAILS TO MANY RECIPIENTS

Option Explicit

Sub Excel_Serial_Mail()
'Andreas Thehos
'http://thehosblog.com

    Dim objOLOutlook As Object
    Dim objOLMail As Object
    Dim lngMailNr As Long
    Dim lngZaehler As Long
    Dim strAttachmentPfad1 As String, strAttachmentPfad2 As String
    Dim strSignatur As String
   
    On Error GoTo ErrorHandler
   
    Set objOLOutlook = CreateObject("Outlook.Application")
    lngMailNr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
   
    'strAttachmentPfad1 = "C:\Users\Lauren Bolek\Pictures\JPG"
    'strAttachmentPfad2 = "C:\Users\Andreas\Documents\YouTube\YouTube 2.jpg"
    'Hier Pfade und Dateien anpassen

   
    For lngZaehler = 2 To lngMailNr
        If Cells(lngZaehler, 1) <> "" Then
            Set objOLMail = objOLOutlook.CreateItem(olMailItem)
            With objOLMail
                .To = Cells(lngZaehler, 1)
                .CC = ""
                .BCC = ""
                .GetInspector.Activate
                strSignatur = .Body
                .Sensitivity = 3
                .Importance = 2
                .Subject = "Vorgabe Wochenplan"
                .BodyFormat = olFormatPlain
                .Body = "Hallo " & Cells(lngZaehler, 3) & "," & vbCrLf & _
                    Cells(lngZaehler, 2).Value & " ist die Zahl des Tages." & vbCrLf & strSignatur
               
                'Hier anpassen
                '.Attachments.Add strAttachmentPfad1
                '.Attachments.Add strAttachmentPfad2
                .Display
                .Send
                '.Display
            End With
            Set objOLMail = Nothing
        End If
     Next lngZaehler
     Set objOLOutlook = Nothing
       
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source, _
        vbInformation, "Ein Fehler ist aufgetreten"
    Exit Sub
End Sub

.Body = "Hallo " & Cells(lngZaehler, 3) & "," & vbCrLf & _
                    Cells(lngZaehler, 2).Value & " ist die Zahl des Tages." & vbCrLf & strSignatur

Start:

 Set objOLOutlook = CreateObject("Outlook.Application")

    lngMailNr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
   
    'strAttachmentPfad1 = "C:\.....\JPG"
    'strAttachmentPfad2 = "C:\.. 2.jpg"
    'Hier Pfade und Dateien anpassen

   
    For lngZaehler = 2 To lngMailNr
        If Cells(lngZaehler, 1) <> "" Then

       Set

       With

End:

          End With
            Set objOLMail = Nothing
        End If
     Next lngZaehler
     Set objOLOutlook = Nothing
       
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source, _
        vbInformation, "Ein Fehler ist aufgetreten"
    Exit Sub
End Sub

Email Title:

       .Subject = "Vorgabe Wochenplan"