VBA for sending Bulk Email with Unique Attachments in XLS to Unique Receipient

[mdasifiqbal]

Dear Friends

Its a VBA made by one of our friend for sending bulk mails to unique mail id with unique attachments, but the same in not functioning as designed as its not picking up the attachment from defined range, can anyone suggest where the problem lies.

Public Sub Send_multiple_email_with_attachements()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range

On Error Resume Next

With ActiveSheet
lastrowTO = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With ActiveSheet
lastrowCC = .Cells(.Rows.Count, "B").End(xlUp).Row
End With

With ActiveSheet
lastrowBCC = .Cells(.Rows.Count, "C").End(xlUp).Row
End With

x = WorksheetFunction.Max(lastrowTO, lastrowCC, lastrowBCC)

For t = 3 To x

If ActiveSheet.Range("K" & t) = "Yes" Or ActiveSheet.Range("K" & t) = "yes" Then

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With ActiveSheet
Set rngTo = ActiveSheet.Range("A" & t)
Set rngCC = ActiveSheet.Range("B" & t)
Set rngBCC = ActiveSheet.Range("C" & t)
Set rngSubject = ActiveSheet.Range("D" & t)
Set rngBody = ActiveSheet.Range("E" & t)
Set rngAttach = ActiveSheet.Range("G" & t)
Set rngVoting = ActiveSheet.Range("J" & t)
End With

With objMail
.VotingOptions = rngVoting.Value
.To = rngTo.Value
.cc = rngCC.Value
.bcc = rngBCC.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.send
End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing

End If

Next t
End Sub

moreover can anyone suggest modifications if any to incorporate Mail Body in the format as below


Dear Sir,

Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices.

Thanks & Regards
Md Asif Iqbal