Macro to send email based on date won't run

Hello,

Please can anyone help with this code, I cannot see my error. Thank you so much for your help.

I have a spreadsheet that tracks new hire orientation and we would like to follow up with them after they have been here a certain period of time. I have attached the work sheet. I have searched all the forums and came up with the following macro but it doesn't work. Can anyone help? Thanks....

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

    For i = 2 To Sheets("Follow-up").Range("e65536").End(xlUp).Row
    'checks cell from col E ....... .....and cell form col G is empty
           If Cells(i, 5).Value = Date + 14 And Cells(i, 7) = "" Then
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
        
                            
            End With
    
            With OutMail
                .To = Cells(i, 7)
                .CC = strcc
                .BCC = strbcc
                .Subject = "Safety Follow-up"
                .Body = "Orientation Safety Follow-up"
                .Send
                
                        Cells(i, 5).Select 'col E
                        With Selection.Font
                         .Color = vbBlack
                         .TintAndShade = 0
                         End With
                        Cells(i, 8) = "Sent at:" & Now() 'col H
            End With
   
            Set OutMail = Nothing
            Set OutApp = Nothing
      End If
      Next i
End Sub

Follow-Up Safety.xlsm