Macro to send email

[joy_666]

Hi,

I have found the below mentioned code from one of the threads.

Sub EmailDoc()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As MailItem
Set olMail = olApp.CreateItem(olMailItem)
Application.ScreenUpdating = False
With olMail
.To = Range("A1").value
.SentOnBehalfOfName = """xyz"" "
.Subject = "Resources"
'.Attachments.Add "D:\test\xyz.xls"
.send
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub

The above code works fine but i want to send emails to all the names in my column A in the To field and in the CC field from column D (It shoulds send if there are any values for the CC field)

Can you help me out...

 

[ColinKJ]

Hi joy_666,

You could try this:

Code:
Sub EmailDoc()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As MailItem
Set olMail = olApp.CreateItem(olMailItem)
Application.ScreenUpdating = False
R = Sheets(1).Range("A65536").End(xlUp).Row
for a=1 to R
With olMail
.To = cells(R,1).text
.CC=cells(R,4).text
.SentOnBehalfOfName = """xyz"" "
.Subject = "Resources"
'.Attachments.Add "D:\test\xyz.xls"
.send
End With
next a
Set olMail = Nothing
Set olApp = Nothing
End Sub

Code:

ColinKJ

 

[joy_666]

Hey Colin,

Thanks for the code.....

It sends for the 1st cell and throws an error after that at
To = cells(R,1).text

 

[ColinKJ]

Hi joy_666,

Try the changes below:

Code:
Sub EmailDoc()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As MailItem
R = Sheets(1).Range("A65536").End(xlUp).Row
for a=1 to R
Set olMail = olApp.CreateItem(olMailItem)
Application.ScreenUpdating = False
With olMail
.To = cells(R,1).text
.CC=cells(R,4).text
.SentOnBehalfOfName = """xyz"" "
.Subject = "Resources"
'.Attachments.Add "D:\test\xyz.xls"
.send
End With
Set olMail = Nothing
Set olApp = Nothing
next a
End Sub

Code:

ColinKJ <!-- / message -->

 

[joy_666]

Hey,

now it does the same but throws an error at

Set olMail = olApp.CreateItem(olMailItem)

 

[ColinKJ]

Hi joy_666,

Try:

Code:
Sub EmailDoc()
Dim olApp As Outlook.Application
Dim olMail As MailItem
R = Sheets(1).Range("A65536").End(xlUp).Row
for a=1 to R
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Application.ScreenUpdating = False
With olMail
.To = cells(R,1).text
.CC=cells(R,4).text
.SentOnBehalfOfName = """xyz"" "
.Subject = "Resources"
'.Attachments.Add "D:\test\xyz.xls"
.send
End With
Set olMail = Nothing
Set olApp = Nothing
next a
End Sub

Code:

A bit of trial and error !!

ColinKJ <!-- / message -->

 

[joy_666]

Okie

We are almost done.....

The problem is that it sends the mails but repeats only the value in A1

 

[ColinKJ]

Hi joy_666,

I must be half asleep to day, try this one:

Sub EmailDoc()
Dim olApp As Outlook.Application
Dim olMail As MailItem
R = Sheets(1).Range("A65536").End(xlUp).Row
for a=1 to R
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Application.ScreenUpdating = False
With olMail
.To = cells(a,1).text
.CC=cells(a,4).text
.SentOnBehalfOfName = """xyz"" "
.Subject = "Resources"
'.Attachments.Add "D:\test\xyz.xls"
.send
End With
Set olMail = Nothing
Set olApp = Nothing
next a
End Sub

Code:

A bit of trial and error !!

ColinKJ <!-- / message -->

 

[joy_666]

Hey!!!

99% done

now it does not let me send the email.

if i use .Display instead of .Send it shows me all the mails to be sent.

Any idea?

 

[ColinKJ]

Hi joy_666,

.Send

Should work, I've only ever used .Display

If it's not working for you, maybe someone else here on the forum can help.

Sorry.

ColinKJ