Excel aufgaben/mails an Outlook

Private Sub SendMessage()
Dim objOutLook As Outlook.Application
Dim objOutlookMsg As Object
Dim objOutlookRecip As Outlook.Recipient
Dim curCell As Range
Set curCell = Range("J9")
Do Until curCell.Value = " "
Set objOutLook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutLook.CreateItem(olMailItem)
With objOutlookMsg
Set objOutlookRecip = .Recipients.Add("A.mail@mail.com")
Set objOutlookRecip = .Recipients.Add("B.mail@mail.com")
Set objOutlookRecip = .Recipients.Add("C.mail@mail.com")    '
objOutlookRecip.Type = olTo
.Subject = "Automatisierungstest mit M Outlook"
.Body = "Test Test" & vbCrLf & vbCrLf
.Importance = olImportanceHigh
.Subject = "INDEX" & "curCell.Offset(0, -2)"
If Not IsEmpty(curCell.Value) Then
.StartDate = Format(curCell.Value, "dd.mm.yyyy", "FirstDayOfWeek")
.ReminderTime = Format(curCell.Value -21, "dd.mm.yyyy", "LastDayOfWeek") & " " & "08:00"    '
End If
.ReminderSet = True
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
Set objOutlookMsg = Nothing
Set objOutLook = Nothing
End With
Set curCell = curCell.Offset(1, 0)
Loop
End Sub