SENDING BULK EMAILS FROM EXCEL VBA IN ONE CLICK/ WITH PARTICULAR PULL ID TO USE

[JOHATUP]

Need help in completing the code i researched where this is to automate mass sending of emails directly to different recipient in the outlook.
In outlook I have few email used which is term as pool ID, so I use different pool ID in outlook depends on who i am sending emails to either personal or work email. As i tried the VBA code it does work however i wanted to mass send the email using my work email/pool ID. Is there anyone who know how how to fix this code to mass send email with the appropriate pool ID or I can do it it will send directly using my work email/ pool ID? Please see my code below and the link to my sample template.

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("Exceltip.com").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

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 created

Set outApp = Nothing

Application.ScreenUpdating = True

Application.ScreenUpdating = True

End Sub

Send-Bulk-EMails-From-Excel-VBA-in-One-Click-1.xlsm

Shared with Dropbox

www.dropbox.com

 

[DanteAmor]

Try the following options to see what works for you.
After this line:

.Subject = subj

Add this line:

.SendUsingAccount = "email/pool"

If it doesn't work then try this line:

.SentOnBehalfOfName = "email/pool"

Change "email/pool" by your email account.