Email loop only sends first email from outlook.

Trying to send multiple individuals different emails based on cells within the worksheet. This basically grabs their organizational data and puts everything into an email so I can send it off and make sure everything is up to date. Problem is, it will shoot off the first email and that is it. It will still go through the whole list and say that it has emailed all contacts that have not been emailed in the last 90 days, but I do not see any emails sent from outlook.

Sub shootmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim X As Integer
    

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Stp = 1

vb = MsgBox("This will send emails to contacts that have not been emailed within 90 days. Do you wish to continue?", vbYesNo)
If vb = vbNo Then Exit Sub
    UserForm2.TextBox1.Text = "I am updating our command contact list and am requesting assistance in ensuring the following information is up to date or provide any missing data.  This is an automated email that gets sent around every 3 months and your assistance in helping maintain our 200+ command P.O.C. database is very helpful.  This information is maintained on a spreadsheet for specific members of our command.  This way, if there are any issues with your individuals that require assistance while here, one of our staff members can contact their counterpart in your command.  Please reply with corrections, fill in missing information, or to let me know that everything is up to date."
    UserForm2.TextBox3.Text = "Sir/Ma'am"
    UserForm2.Show
    Sheets("Update POC").Select
    Range("A1").Select
    If Stp = 1 Then Exit Sub
    
    'Get CO's Data

Do
    Sheets("Update POC").Select
    ActiveCell.Offset(1, 0).Select
If ActiveCell.Offset(0, 3).Value = "" Then GoTo A
If Date - ActiveCell.Offset(0, 3).Value > 90 Then
A:
        If ActiveCell.Offset(0, 1).Value = "" Then
        Else
        M2 = ActiveCell.Offset(0, 1).Value
        CMD = ActiveCell.Value
        Sheets("COs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            If ActiveCell.Value = "" Then
                MsgBox ("We were unable to find " & CMD & ".  Please make sure that it is in the command listing or removed from the Update POC list.")
                Sheets("Update POC").Select
                Exit Sub
            Else
            End If
            
            Loop Until ActiveCell.Value = CMD
            CO1 = ActiveCell.Offset(0, 2).Value
            CO2 = ActiveCell.Offset(0, 3).Value
            CO3 = ActiveCell.Offset(0, 4).Text
            ADX = ActiveCell.Offset(0, 6).Text
            
        Sheets("XOs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            XO1 = ActiveCell.Offset(0, 2).Value
            XO2 = ActiveCell.Offset(0, 3).Value
            XO3 = ActiveCell.Offset(0, 4).Text
            XO4 = ActiveCell.Offset(0, 5).Text
                
        Sheets("CMCs and COBs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            XO1 = ActiveCell.Offset(0, 2).Value
            XO2 = ActiveCell.Offset(0, 3).Value
            XO3 = ActiveCell.Offset(0, 4).Text
            XO4 = ActiveCell.Offset(0, 5).Text
                
        Sheets("JAGs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            JG1 = ActiveCell.Offset(0, 2).Value
            JG2 = ActiveCell.Offset(0, 3).Value
            JG3 = ActiveCell.Offset(0, 4).Text
            JG4 = ActiveCell.Offset(0, 5).Text
        
        Sheets("ADMIN").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            AD1 = ActiveCell.Offset(0, 2).Value
            AD2 = ActiveCell.Offset(0, 3).Value
            AD3 = ActiveCell.Offset(0, 4).Text
            AD4 = ActiveCell.Offset(0, 5).Text
        
        Sheets("CCC").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            CC1 = ActiveCell.Offset(0, 2).Value
            CC2 = ActiveCell.Offset(0, 3).Value
            CC3 = ActiveCell.Offset(0, 4).Text
            CC4 = ActiveCell.Offset(0, 5).Text
        
    
        strbody = "Dear " & T2 & "," & vbNewLine & vbNewLine & _
                  "     " & MSG & vbNewLine & vbNewLine & vbNewLine & _
                  "Command: " & CMD & vbNewLine & vbNewLine & _
                  "Commanding Officer: " & CO1 & vbNewLine & _
                  "Email Address: " & CO2 & vbNewLine & _
                  "Phone Number:  " & CO3 & vbNewLine & vbNewLine & _
                  "Executive Officer: " & XO1 & vbNewLine & _
                  "Email Address: " & XO2 & vbNewLine & _
                  "Phone Number: " & XO3 & vbNewLine & _
                  "Cell Number:  " & XO4 & vbNewLine & vbNewLine & _
                  "CMC/COB: " & CM1 & vbNewLine & _
                  "Email Address: " & CM2 & vbNewLine & _
                  "Phone Number: " & CM3 & vbNewLine & _
                  "Cell Number:  " & CM4 & vbNewLine & vbNewLine & _
                  "JAG: " & JA1 & vbNewLine & _
                  "Email Address: " & JA2 & vbNewLine & _
                  "Phone Number:  " & JA3 & vbNewLine & vbNewLine & _
                  "Admin Officer: " & AD1 & vbNewLine & _
                  "Email Address: " & AD2 & vbNewLine & _
                  "Phone Number:  " & AD3 & vbNewLine & vbNewLine & _
                  "CCC: " & CC1 & vbNewLine & _
                  "Email Address: " & CC2 & vbNewLine & _
                  "Phone Number:  " & CC3 & vbNewLine & ADX & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
                  "Very Respectfully," & vbNewLine & vbNewLine & vbNewLine & _
                  "" & NM & vbNewLine & "Phone: (COM 360/DSN 744) " & PhN
                  
    
    
                  
    
        On Error Resume Next
        With OutMail
            .To = M2
            .CC = ""
            .BCC = ""
            .Subject = "TPU Contact list update"
            .Body = strbody
            .Display  'or use .Send
            Application.Wait Time + TimeSerial(0, 0, 5)
        End With
        On Error GoTo 0
        Sheets("Update POC").Select
        ActiveCell.Offset(0, 3).Value = Date
        End If
    
Else
End If


Loop Until ActiveCell.Value = ""


    Set OutMail = Nothing
    Set OutApp = Nothing



End Sub