Wait until email is sent in Outlook before moving to next cell row

I will start by saying I am inexperienced and completely experimenting to make my current job easier. Any suggestions on top of my actual question are welcomed.

So this VBA macro for excel which should take info from specific cells in each row and use that to populate an automated email follow up. The script works as-is but when it runs, it moves through each row of the sheet and opens an email draft in Outlook. This is problematic when the sheet has too many lines, Outlook will typically crash. I have tried using various loops but it either breaks the script or cases the draft to reopen forcing me to have to kill Outlook

Is there a way to have each line open the respective draft and wait until the window is either closed or sent before it moves on to the next line?

I am using .Display rather than .Send so that the email drafts can be reviewed, edited, or cancelled prior to send.

Is there something that checks for .Display = True before moving to the new row in excel

Current Code:

Sub SendEmails()
       Dim OutApp As Object
       Dim OutMail As Object
       Dim cell As Range
       Dim Name As String
       Dim FirstName As String
       Dim LastName As String
       Dim Temp

       Application.ScreenUpdating = False
       Set OutApp = CreateObject("Outlook.Application")

       On Error GoTo cleanup

       For Each cell In Columns("W").Cells.SpecialCells(xlCellTypeConstants)
            i = cell.Row                                                                
            Temp = Split(Sheets("Sheet1").Range("P"& i).Value)                         
            FirstName = WorksheetFunction.Proper(Temp(LBound(Temp)))                   

            If Sheets("Sheet1").Range("A"& i).Value = "Yellow" And Sheets("Sheet1").Range("AE"& i).Value = "Red" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .subject = "Yellow Red"& Sheets("Sheet1").Range("A"& i).Value & " - "& Sheets("Sheet1").Range("D"& i).Value
                .HTMLBody = "<p>Good Afternoon "& FirstName & ","& "</p>"& "<p>Thank you for Yellow.</p>"& "<p> Thanks </p>"
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
            End If

            If Sheets("Sheet1").Range("A"& i).Value = "Blue" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .subject = "Blue"& Sheets("Sheet1").Range("A"& i).Value & " - "& Sheets("Sheet1").Range("D"& i).Value
                .HTMLBody = "<p>Good Afternoon "& FirstName & ","& "</p>"& "<p>Thank you for Blue.</p>"& "<p> Thanks </p>"
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
            End If

            If Sheets("Sheet1").Range("A"& i).Value = "Yellow" And Sheets("Sheet1").Range("AE"& i).Value <> "Red" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .subject = "Yellow"& Sheets("Sheet1").Range("A"& i).Value & " - "& Sheets("Sheet1").Range("D"& i).Value
                .HTMLBody = "<p>Good Afternoon "& FirstName & ","& "</p>"& "<p>Thank you for Yellow .</p>"& "<p> Thanks </p>"
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
            End If



       Next cell

cleanup:
            Set OutApp = Nothing
            Application.ScreenUpdating = True
  End Sub