Automatic emsil to be sent to Mutliple Recipients from Excel to outlook

Hi There, I am using below code to send mail automatically from excel which has some range of data to b sent. I want to send mail to many recipients in To and CC, where should I modify, below code is working fine to send email to my own id: also this mail goes everyday and the date in the subject line should automatically consider current date of every day.

 Sub Mail_Sheet_Outlook_Body()
     Dim rng As Range
     Dim OutApp As Object
     Dim OutMail As Object
     
     With Application
         .EnableEvents = False
         .ScreenUpdating = False
     End With

     Set rng = Nothing
     Set rng = ActiveSheet.UsedRange
     'You can also use a sheet name
     'Set rng = Sheets("YourSheet").UsedRange

     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

     On Error Resume Next
     With OutMail
         .To = "kausalya.durgale@accenture.com"
         .CC = ""
         .BCC = ""
         .Subject = "Service Check 12-01-2018,NEED YOUR CONFIRMATION by 01:30 PM IST "
         .HTMLBody = RangetoHTML(rng)
         .Send   'or use .Display
     End With
     On Error GoTo 0
     

     With Application
         .EnableEvents = True
         .ScreenUpdating = True
     End With

     Set OutMail = Nothing
     Set OutApp = Nothing
 End Sub


 Function RangetoHTML(rng As Range)
     Dim fso As Object
     Dim ts As Object
     Dim TempFile As String
     Dim TempWB As Workbook

     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

     'Copy the range and create a new workbook to past the data in
     rng.Copy
     Set TempWB = Workbooks.Add(1)
     With TempWB.Sheets(1)
         .Cells(1).PasteSpecial Paste:=8
         .Cells(1).PasteSpecial xlPasteValues, , False, False
         .Cells(1).PasteSpecial xlPasteFormats, , False, False
         .Cells(1).Select
         Application.CutCopyMode = False
         On Error Resume Next
         .DrawingObjects.Visible = True
         .DrawingObjects.Delete
         On Error GoTo 0
     End With

     'Publish the sheet to a htm file
     With TempWB.PublishObjects.Add( _
          SourceType:=xlSourceRange, _
          Filename:=TempFile, _
          Sheet:=TempWB.Sheets(1).Name, _
          Source:=TempWB.Sheets(1).UsedRange.Address, _
          HtmlType:=xlHtmlStatic)
         .Publish (True)
     End With

     'Read all data from the htm file into RangetoHTML
     Set fso = CreateObject("Scripting.FileSystemObject")
     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
     RangetoHTML = ts.readall
     ts.Close
     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                           "align=left x:publishsource=")

     'Close TempWB
     TempWB.Close savechanges:=False

     'Delete the htm file we used in this function
     Kill TempFile

     Set ts = Nothing
     Set fso = Nothing
     Set TempWB = Nothing
 End Function
kausalya durgaleAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

yo_beeDirector of Information TechnologyCommented:
Do you have a static set of people that this needs to go to.  You can create a distribution  group and add the recipients there  and replace  kausalya.durgale@accenture.com with groupname@accenture.com.  Another method you can use is change "kausalya.durgale@accenture.com " to "kausalya.durgale@accenture.com; john.smith@accenture.com; jill.smith@accenture.com" just keep adding to the string.  Also if you like to clean this up a bit you can remove .CC="" and .BCC=""   since that they are not populated

Option 1:
 Sub Mail_Sheet_Outlook_Body()
     Dim rng As Range
     Dim OutApp As Object
     Dim OutMail As Object
     
     With Application
         .EnableEvents = False
         .ScreenUpdating = False
     End With

     Set rng = Nothing
     Set rng = ActiveSheet.UsedRange
     'You can also use a sheet name
     'Set rng = Sheets("YourSheet").UsedRange

     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

     On Error Resume Next
     With OutMail
         .To = "Groupname@accenture.com"
         .CC = ""
         .BCC = ""
         .Subject = "Service Check 12-01-2018,NEED YOUR CONFIRMATION by 01:30 PM IST "
         .HTMLBody = RangetoHTML(rng)
         .Send   'or use .Display
     End With
     On Error GoTo 0
     

     With Application
         .EnableEvents = True
         .ScreenUpdating = True
     End With

     Set OutMail = Nothing
     Set OutApp = Nothing
 End Sub


 Function RangetoHTML(rng As Range)
     Dim fso As Object
     Dim ts As Object
     Dim TempFile As String
     Dim TempWB As Workbook

     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

     'Copy the range and create a new workbook to past the data in
     rng.Copy
     Set TempWB = Workbooks.Add(1)
     With TempWB.Sheets(1)
         .Cells(1).PasteSpecial Paste:=8
         .Cells(1).PasteSpecial xlPasteValues, , False, False
         .Cells(1).PasteSpecial xlPasteFormats, , False, False
         .Cells(1).Select
         Application.CutCopyMode = False
         On Error Resume Next
         .DrawingObjects.Visible = True
         .DrawingObjects.Delete
         On Error GoTo 0
     End With

     'Publish the sheet to a htm file
     With TempWB.PublishObjects.Add( _
          SourceType:=xlSourceRange, _
          Filename:=TempFile, _
          Sheet:=TempWB.Sheets(1).Name, _
          Source:=TempWB.Sheets(1).UsedRange.Address, _
          HtmlType:=xlHtmlStatic)
         .Publish (True)
     End With

     'Read all data from the htm file into RangetoHTML
     Set fso = CreateObject("Scripting.FileSystemObject")
     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
     RangetoHTML = ts.readall
     ts.Close
     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                           "align=left x:publishsource=")

     'Close TempWB
     TempWB.Close savechanges:=False

     'Delete the htm file we used in this function
     Kill TempFile

     Set ts = Nothing
     Set fso = Nothing
     Set TempWB = Nothing
 End Function 

Open in new window


Option 2:

 Sub Mail_Sheet_Outlook_Body()
     Dim rng As Range
     Dim OutApp As Object
     Dim OutMail As Object
     
     With Application
         .EnableEvents = False
         .ScreenUpdating = False
     End With

     Set rng = Nothing
     Set rng = ActiveSheet.UsedRange
     'You can also use a sheet name
     'Set rng = Sheets("YourSheet").UsedRange

     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

     On Error Resume Next
     With OutMail
         .To =kausalya.durgale@accenture.com; john.smith@accenture.com; jill.smith@accenture.com"
         .CC = ""
         .BCC = ""
         .Subject = "Service Check 12-01-2018,NEED YOUR CONFIRMATION by 01:30 PM IST "
         .HTMLBody = RangetoHTML(rng)
         .Send   'or use .Display
     End With
     On Error GoTo 0
     

     With Application
         .EnableEvents = True
         .ScreenUpdating = True
     End With

     Set OutMail = Nothing
     Set OutApp = Nothing
 End Sub


 Function RangetoHTML(rng As Range)
     Dim fso As Object
     Dim ts As Object
     Dim TempFile As String
     Dim TempWB As Workbook

     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

     'Copy the range and create a new workbook to past the data in
     rng.Copy
     Set TempWB = Workbooks.Add(1)
     With TempWB.Sheets(1)
         .Cells(1).PasteSpecial Paste:=8
         .Cells(1).PasteSpecial xlPasteValues, , False, False
         .Cells(1).PasteSpecial xlPasteFormats, , False, False
         .Cells(1).Select
         Application.CutCopyMode = False
         On Error Resume Next
         .DrawingObjects.Visible = True
         .DrawingObjects.Delete
         On Error GoTo 0
     End With

     'Publish the sheet to a htm file
     With TempWB.PublishObjects.Add( _
          SourceType:=xlSourceRange, _
          Filename:=TempFile, _
          Sheet:=TempWB.Sheets(1).Name, _
          Source:=TempWB.Sheets(1).UsedRange.Address, _
          HtmlType:=xlHtmlStatic)
         .Publish (True)
     End With

     'Read all data from the htm file into RangetoHTML
     Set fso = CreateObject("Scripting.FileSystemObject")
     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
     RangetoHTML = ts.readall
     ts.Close
     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                           "align=left x:publishsource=")

     'Close TempWB
     TempWB.Close savechanges:=False

     'Delete the htm file we used in this function
     Kill TempFile

     Set ts = Nothing
     Set fso = Nothing
     Set TempWB = Nothing
 End Function 

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
kausalya durgaleAuthor Commented:
Thank you for the response! I have replaced mail id's with ; which i was trying initially by separating comma's. hope this will work the same way when I add recipients in CC list as well..

Also, as this is a daily mailer, can i get current date in the subject line after "service health check" else we have to modify the code everyday to change the date before we run the code.
yo_beeDirector of Information TechnologyCommented:
Email need semi-columns. Email address display names could have commas and they are not used as delimiters for this reason.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.