not working i'm afraid, won't stop sending emails...

Private Sub Workbook_Open()
Dim ce As Range, i As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String, strcc As String, strbcc As String
    Dim strsub As String, strbody As String
Dim MyName As String

    MyName = ThisWorkbook.Name

    For i = 13 To Sheets("Sheet1").Range("l65536").End(xlUp).Row
        If Cells(i, 12).Value <= Date Then
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
        
            With Sheets("Sheet1")
                strto = "karl.cassidy@argos.co.uk"
                strcc = ""
                strbcc = ""
                strsub = MyName
                strbody = "Hi Sarah," & "This range is either late for handing over, or the PIC hasn't populated a date in CT HO column" & " " & MyName 'vbNewLine & vbNewLine & _

            End With
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .Body = strbody
                .Send
                Cells(i, 12).Select
     With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
            End With
    
            Set OutMail = Nothing
            Set OutApp = Nothing
        End If
  
    Next i
End Sub