Send email from excel

B

Beneindias

Board Regular
Joined
Jun 21, 2022
Messages
120
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi guys,

I have an excel file with a table, where I have clients and providers emails in column C.

I have the subject in cell G4
And I have the body of the email in cell G5.

I have a code written, but, it's not working as expected.

I was trying to loop through column C and past the emails to BCC field, after all emails are added to BCC, should populate subject(G4) and body(G5), and use my signature that is stored in outlook app.

Problem is:
- This code is not puting emails in bcc or in any field.
- The body is being pasted to outlook 2x instead of only one
- It's not using my signature.

Can you look in this code and help me?
It's the first time that i'm tryin to send emails from excel, so, I don't undestand what's missing.

VBA Code: 
Sub SendEmails()

'Declare variables
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Dim rng As Range, cell As Range
Dim email As String

'Create an instance of Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Create a new email
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

'Loop through each cell in column C
For Each cell In ActiveSheet.Range("C1:C" & ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)

'Check if the cell contains an email address
If (InStr(1, email, "@") > 0) And _
              (InStr(InStr(1, email, "@"), email, ".") > InStr(1, email, "@")) Then

'Populate the email properties
With OutlookMail
.Bcc = .Bcc & ";" & cell.Value
End With

End If

Next cell

'Populate the remaining email properties
With OutlookMail
.Subject = ActiveSheet.Range("G4").Value
.Body = ActiveSheet.Range("G5").Value
.HTMLBody = "<HTML>" & "<BODY>" & .Body & "<br>" & OutlookMail.HTMLBody & "</BODY>" & "</HTML>"
.Display
'.Send
End With

'Cleanup
Set OutlookMail = Nothing
Set OutlookApp = Nothing


End Sub


Now, another question:

It's better to put all emails in bcc and send one big group email, or send an email for each contact?
(Don't want to be flagged as spam, because this is to send an email to our clients and providers.)


Thank you all
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Hi,

try the following.
you can use .Body or .HTMLBody for the email - not both
.Send is commented out for testing first.

It is entirely your choice on whether you deliver a single mail or use BCC.

Code: 
Sub Send_a_mail()



Set OutlookApp = CreateObject("Outlook.Application")

'Create a new email
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

'Loop through each cell in column C
For Each cell In ActiveSheet.Range("C1:C" & ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)

'Check if the cell contains an email address
If (InStr(1, cell.Value, "@") > 0) And _
              (InStr(InStr(1, cell.Value, "@"), cell.Value, ".") > InStr(1, cell.Value, "@")) Then


strBCC = strBCC & cell.Value & "; "

End If
Next cell

 strTo = "???"

 strBody = "<html><body><p>" & "Hi<br><br>" & ActiveSheet.Range("G5").Value & "</p></body></html>"
' you can format the message content with HTML tags here but you really only need it for things like modifying font sizes, colours etc. The .HTMLBody does not require the tags.
' So strBody = ActiveSheet.Range("G5").Value would probably be sufficient for you.

'Populate the email properties
    With OutlookMail
        .Display
        .To = strTo
        '.CC = ""
        .BCC = strBCC
        .Subject = ActiveSheet.Range("G4").Value
        .HTMLBody = strBody & "<br><br>" & .HTMLBody & signature
       ' .Send
    End With

'Cleanup
Set OutlookMail = Nothing
Set OutlookApp = Nothing

End Sub
 
Last edited:
Upvote 0
daverunt said:
Hi,

try the following.
you can use .Body or .HTMLBody for the email - not both
.Send is commented out for testing first.

It is entirely your choice on whether you deliver a single mail or use BCC.

Code: 
Sub Send_a_mail()



Set OutlookApp = CreateObject("Outlook.Application")

'Create a new email
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

'Loop through each cell in column C
For Each cell In ActiveSheet.Range("C1:C" & ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)

'Check if the cell contains an email address
If (InStr(1, cell.Value, "@") > 0) And _
              (InStr(InStr(1, cell.Value, "@"), cell.Value, ".") > InStr(1, cell.Value, "@")) Then


strBCC = strBCC & cell.Value & "; "

End If
Next cell

 strTo = "???"

 strBody = "<html><body><p>" & "Hi<br><br>" & ActiveSheet.Range("G5").Value & "</p></body></html>"
' you can format the message content with HTML tags here but you really only need it for things like modifying font sizes, colours etc. The .HTMLBody does not require the tags.
' So strBody = ActiveSheet.Range("G5").Value would probably be sufficient for you.

'Populate the email properties
    With OutlookMail
        .Display
        .To = strTo
        '.CC = ""
        .BCC = strBCC
        .Subject = ActiveSheet.Range("G4").Value
        .HTMLBody = strBody & "<br><br>" & .HTMLBody & signature
       ' .Send
    End With

'Cleanup
Set OutlookMail = Nothing
Set OutlookApp = Nothing

End Sub
Click to expand...

Hi, daverunt

Thanks for your help.

This solved the problems that I was having, but, now, the text that I have in cell G5 shows all in one line in my email, but, in my excel file I have the text with proper line spaces, and all that.

While I was trying to solve my code, I noticed that if I used .body, the text would show as only one line, but if used .HTMLBody, it was proper formating.
Meanwhile, this code that you created, uses HTMLBody, but the text is not ok.

Any way to solve this without using vbNewLine?
 
Upvote 0
Hi,

Try adding the function RangetoHTML and changing the code to use it.

Code: 
Sub Send_a_mail()



Set OutlookApp = CreateObject("Outlook.Application")

'Create a new email
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

'Loop through each cell in column C
For Each cell In ActiveSheet.Range("C1:C" & ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)

'Check if the cell contains an email address
If (InStr(1, cell.Value, "@") > 0) And _
              (InStr(InStr(1, cell.Value, "@"), cell.Value, ".") > InStr(1, cell.Value, "@")) Then


strBCC = strBCC & cell.Value & "; "


End If
Next cell

 strToo = "???"

 'strBody = "<html><body><p>" & "Hi<br><br>" & ActiveSheet.Range("G5").Value & "</p></body></html>" ' comment this out and use the range in the mail below, which uses the function. That should copy the cell AS IS

'Populate the email properties
    With OutlookMail
        .Display
        .To = strToo
        '.CC = ""
        .BCC = strBCC
        .Subject = ActiveSheet.Range("G4").Value
        .HTMLBody = RangetoHTML(Range("G5")) & "<br><br>" & .HTMLBody & signature
       ' .Send
    End With

'Cleanup
Set OutlookMail = Nothing
Set OutlookApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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
 
Upvote 0
Solution
daverunt said:
Hi,

Try adding the function RangetoHTML and changing the code to use it.

Code: 
Sub Send_a_mail()



Set OutlookApp = CreateObject("Outlook.Application")

'Create a new email
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

'Loop through each cell in column C
For Each cell In ActiveSheet.Range("C1:C" & ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)

'Check if the cell contains an email address
If (InStr(1, cell.Value, "@") > 0) And _
              (InStr(InStr(1, cell.Value, "@"), cell.Value, ".") > InStr(1, cell.Value, "@")) Then


strBCC = strBCC & cell.Value & "; "


End If
Next cell

 strToo = "???"

 'strBody = "<html><body><p>" & "Hi<br><br>" & ActiveSheet.Range("G5").Value & "</p></body></html>" ' comment this out and use the range in the mail below, which uses the function. That should copy the cell AS IS

'Populate the email properties
    With OutlookMail
        .Display
        .To = strToo
        '.CC = ""
        .BCC = strBCC
        .Subject = ActiveSheet.Range("G4").Value
        .HTMLBody = RangetoHTML(Range("G5")) & "<br><br>" & .HTMLBody & signature
       ' .Send
    End With

'Cleanup
Set OutlookMail = Nothing
Set OutlookApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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
Click to expand...
This one worked.

Many thanks for your help, I would never get to that function on my own.

Have a nice weekend
 
Upvote 0
Beneindias said:
This one worked.

Many thanks for your help, I would never get to that function on my own.

Have a nice weekend
Click to expand...
You are welcome.
I would never get to it on my own either.
The function is very useful as it can copy a range or several with the source format intact.

It comes from the Ron De Bruin site here:
A useful source for vba macros for Outlook related email.
 
Upvote 0
You must log in or register to reply here.

Similar threads

KlausW
  • Solved
Change Attachments from XLSM to XLSX in mail
Replies
5
Views
283
Micron
M
D
  • Question Question
VBA change to not show a sent email in outlook
Replies
6
Views
446
Dspace
D
C
  • Solved
Add a table to e-mail to be sent to multiple addreses
Replies
3
Views
207
mumps
mumps
KlausW
  • Solved
Take fil name from cell
Replies
4
Views
246
KlausW
KlausW
J
  • Question Question
VBA code to send an email if a certain IF Criteria is met that loops when the spreadsheet is open
Replies
1
Views
583
joeyc123
J

Forum statistics

Threads
1,223,884
Messages
6,175,175
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top