Auto emailing in the BCC column

**tnewell2** · 01-11-2013, 08:37 AM

Dear All,

A bit stuck. I have created a workbook that searches for a list of operators dependant on search criteria.
Then emails them a range that we edit.

The problem comes when the email sent needs to be in a different format.
I need help editing the macro so all the email addresses that come up in the search fill the BCC list in 1 email instead of 1 email per address.

I can then .Display the email and put the more complicated body in manually and only have to send it once to everyone.

Sub Email()
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim cell As Range
    For Each cell In Range("L4:L23")
        strbody = strbody & cell.Value & vbNewLine
    Next
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "E").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .BCC = ""
                .Subject = "Quotation Request"
                .Body = "Dear " & Cells(cell.Row, "B").Value & vbNewLine & strbody
                .SendUsingAccount = OutApp.Session.Accounts.Item(3)
                .Display  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

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

I have attached the file.
Any help is appreciated

Tom

**TMS** · 01-11-2013, 10:07 AM

Try:

Sub sEmail()
    Dim OutApp
    Dim OutMail
    Dim cell As Range
    Dim sbcc As String
    For Each cell In Range("L4:L23")
        strbody = strbody & cell.Value & vbNewLine
    Next
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" _
        And LCase(Cells(cell.Row, "E").Value) = "yes" _
        Then
            sbcc = sbcc & cell.Value & ";"
        End If
    Next cell

    If sbcc <> "" Then
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = ""
            .BCC = sbcc
            .Subject = "Quotation Request"
            .Body = "Dear " & Cells(cell.Row, "B").Value & vbNewLine & strbody
            .SendUsingAccount = OutApp.Session.Accounts.Item(3)
            .Display  'Or use Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If

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

Regards, TMS