Send Email VBA

[syedasadali]

I have the following code for sending the email in bulk, unfortunately, I'm unable to set the status as I need the status in Column "H" if the email sends then the status would be "sent" and if not send it could be updated as "Not Sent" Can anyone please help me in this to get the status of the sent emails?


Sub BulkMail()
Application.ScreenUpdating = False

ThisWorkbook.Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem

'Creating variable to hold values of different items of mail
Dim sendTo, subj, atchmnt, msg, ccTo, bccTo As String

Dim lstRow As Long

'My data is on sheet "Exceltip.com" you can have any sheet name.

ThisWorkbook.Sheets("ToolforEmail").Activate
'Getting last row of containing email id in column 3.
lstRow = Cells(Rows.Count, 3).End(xlUp).Row

'Variable to hold all email ids

Dim rng As Range
Set rng = Range("C2:C" & lstRow)

'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.

'Loop to iterate through each row, hold data in of email in variables and send 'mail to each email id.

For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = Range(cell.Address).Offset(0, 1).Value2 & "-MS"
msg = Range(cell.Address).Offset(0, 2).Value2
atchmnt = Range(cell.Address).Offset(0, -1).Value2
ccTo = Range(cell.Address).Offset(0, 3).Value2
bccTo = Range(cell.Address).Offset(0, 4).Value2

On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)

'Writing and sending mail in new mail
With outMail
.To = sendTo
.cc = ccTo
.BCC = bccTo
.Body = msg
.Subject = subj
.Attachments.Add atchmnt
.Send 'this send mail without any notification. If you want see mail
'before send, use .Display method.
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends

cleanup: 'freeing all objects ceated
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True

MsgBox "Emails Sent", vbInformation

End Sub

 

[DanteAmor]

Hi and welcome to MrExcel.
Try this:

Sub BulkMail()
  'Creating references to Application and MailItem Objects of Outlook
  Dim outApp As Outlook.Application
  Dim outMail As Outlook.MailItem
  Dim cell As Range
  Dim sendTo As String, subj As String, atchmnt As String
  Dim msg As String, ccTo As String, bccTo As String
  
  Application.ScreenUpdating = False
  
  ThisWorkbook.Activate
  ThisWorkbook.Sheets("ToolforEmail").Activate
  'initializing outlook object to access its features
  Set outApp = New Outlook.Application
  
  'Loop to iterate through each row, hold data in of email in variables and send 'mail to each email id.
  For Each cell In Range("C2", Range("C" & Rows.Count).End(3))
    sendTo = Range(cell.Address).Offset(0, 0).Value2
    subj = Range(cell.Address).Offset(0, 1).Value2 & "-MS"
    msg = Range(cell.Address).Offset(0, 2).Value2
    atchmnt = Range(cell.Address).Offset(0, -1).Value2
    ccTo = Range(cell.Address).Offset(0, 3).Value2
    bccTo = Range(cell.Address).Offset(0, 4).Value2
    
    On Error Resume Next 'to hand any error during creation of below object
    Set outMail = outApp.CreateItem(0)
    
    'Writing and sending mail in new mail
    With outMail
      .To = sendTo
      .cc = ccTo
      .BCC = bccTo
      .Body = msg
      .Subject = subj
      If atchmnt <> "" Then
        If Dir(atchmnt) <> "" Then .Attachments.Add atchmnt
      End If
      'before send, use .Display method.
      .Send 'this send mail without any notification. If you want see mail
      If Err.Number <> 0 Then
        Range("H" & cell.Row).Value = "Not Sent"
      Else
        Range("H" & cell.Row).Value = "Sent"
      End If
    End With
    'On Error GoTo 0 'To clean any error captured earlier
    Set outMail = Nothing 'nullifying outmail object for next mail
  Next cell 'loop ends
  
  Set outApp = Nothing
  Application.ScreenUpdating = True
  MsgBox "Emails Sent", vbInformation
End Sub