Tweak to VBA email code

[SlightlyClueless]

Hello All,

A while ago I put together a workbook that would allow a user to send a bulk group of emails with attachments to whomever was listed. It will check the cells in row a for "Yes" and if that value is found it will send an email to the individual listed for that row. Other than having to limit the range of emails going out to 100 rows each time the send button is pressed, things work fine. Normally I would change the code to ".Display" instead of" .Send" in order to review the generated email before running the actual sending. I tried to modify the code to generate and display the email when the "test email" button clicked. I was unsuccessful in getting just the first row to be generated as with the "Test Email" button being pressed. Could someone take a look at the code that is working and let me know what needs to be changed so that I do not have to flip the code from ".Send" to ".display" and only have the first row display.

Private Sub CommandButton1_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strbody As String
    Dim signature As String
 
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Range(Range("b3").Value).Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "A").Value) = "yes" _
           And LCase(Cells(cell.Row, "A").Value) <> "Sent" Then

            Set OutMail = OutApp.CreateItem(0)
            With OutMail
            .Display
            End With
            signature = OutMail.body
            
            On Error Resume Next
             With OutMail

                .to = Cells(cell.Row, "D")
                .Subject = "Dynamic Subject Line"
                .cc = ""
                .htmlbody = strbody & "<font size=3>Hello " & Cells(cell.Row, "C").Value & "," & vbNewLine & _
"<p>EMail Body" & vbNewLine & _
"<p>EMail Body" & vbNewLine & _
"" & .htmlbody
                .htmlbody = Replace(.htmlbody, "< ", "<")
                .Attachments.Add (Range("b1").Value)
                .Attachments.Add (Range("b2").Value)
                .Display
            End With
            On Error GoTo 0
            Cells(cell.Row, "A").Value = "Sent"
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub

 

[rollis13]

Quick and dirty: in your Test Mail macro add an Exit Sub or, even better, a GoTo cleanup just after the .Display line.

 

[SlightlyClueless]

Quick and dirty: in your Test Mail macro add an Exit Sub or, even better, a GoTo cleanup just after the .Display line.

Thank you!!! Worked perfectly

 

[rollis13]

Thanks for the positive feedback, glad having been of some help.
By the way, you probably need to mark this thread as [Solved].