I have created a table that will be placed in the body of an Outlook email in HTML format. I am struggling to place the values into proper columns. I have been playing around with "td" tags, but unsuccessful. All the values are now next to each other without spaces between them and therefore not in proper table format. Please help!
My code:
Public Sub HypMail4()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set Out App = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & _
"<html>" & "<table>" & "<font color = ""red""><b>" & Range("A1") &
Range("B1") & Range("C1") & Range("D1") & Range("E1") & "</font></b>" & "
</th>" & _
"<tr>" & Range("A2") & Range("B2") & Range("C2") & Range("D2") & Range("E2")
& "</tr>"
strbody = strbody & _
"<tr>" & Range("A3") & Range("B3") & Range("C3") & Range("D3") & Range("E3")
& "</tr>"
strbody = strbody & _
"<tr>" & Range("A4") & Range("B4") & Range("C4") & Range("D4") & Range("E4")
& "</tr>" & "</table>" & "</html>"
On Error Resume Next
With OutMail
.To = "zzz#example.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I managed to answer my question myself by indeed including td tags. The main problem, however, was that I defined strbody too many times which messed up the table format (hence td tags weren't working) - please see code below:
Public Sub Test()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<html>" & "<table>" & "<tr>" & "<td>" & Range("A1") & "</td>" & "<td>" & Range("B1") & "</td>" & "<td>" & Range("C1") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A2") & "</td>" & "<td>" & Range("B2") & "</td>" & "<td>" & Range("C2") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A3") & "</td>" & "<td>" & Range("B3") & "</td>" & "<td>" & Range("C3") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A4") & "</td>" & "<td>" & Range("B4") & "</td>" & "<td>" & Range("C4") & "</td>" & "</tr>" & "</table>" & "</html>"
With OutMail
.To = "zzz.com#zzz.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Related
I have a small piece of vba-code running perfect in office 2010. When running in office 365, it gives an "index out of range"-error, but not when I step into the code with the Outmail-variabele open in the locals-window. The aim of the code is to attach one or more pdf's to a template mail.
The error is when Display in yellow.
Sub Mailing()
Dim OutApp As Object
Dim OutMail As Object
Dim onderworpenNL As String
Dim onderworpenFR As String
onderworpenNL = "some text"
onderworpenFR = "some text"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
With OutMail
.SentOnBehalfOfName = "dd#dd.com"
.to = Range("H" & (ActiveCell.Row))
.Subject = "some text: " & Range("B" & (ActiveCell.Row)) & " - " & "account: " & Range("A" & (ActiveCell.Row))
.HTMLBody = Replace(.HTMLBody, "REPLACENAAM", Range("B" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEWHK", Range("C" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENNL", Range("F" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENFR", Range("F" & (ActiveCell.Row)))
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", onderworpenNL)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", "")
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", onderworpenFR)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", "")
On Error Resume Next
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & ".pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_1.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_2.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_3.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_4.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_5.pdf"
On Error GoTo 0
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Just change
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
For
Set OutMail = OutApp.CreateItem(0)
and it shall work in both excels
I'm looking to make an automated email script using vba to read from an Excel spreadsheet; the email address and dates (that sort of thing) then place them into the correct fields to send
It would be preferable if it could also finish the line of the spreadsheet and start a new one with a new email
I can currently make an email with vba but that's about it and manually dictate the fields within the script but that's about it. Any help on how to input cell data automatically would be much appreciated.
Thanks :)
Edit 1:
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & Range("C" & Line).Value & " " & Range("B" & Line).Value & " - " & Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & Range("C" & Line).Value & " " & Range("B" & Line).Value & "'s appointment with Dr " & Range("E" & Line).Value & " on " & Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
This seems to be the solve in case anyone has the same issue.
Thanks
The below code is more specific when defining the cells, which worked during my testing.
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = ws.Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & " - " & ws.Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & ws.Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & "'s appointment with Dr " & ws.Range("E" & Line).Value & " on " & ws.Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
I used below macro to create email with embedded picture but it didn't work, as I kept on receiving
run time error 5 "Invalid procedure call or argument"
and highlighted this code .BodyFormat = olFormatHTML.
Sub Outlook_Email_With_Inline_Image()
'Add reference to Microsoft Outlook Object Library
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'Dim OutApp As Outlook.Application
'Dim oOutlookEmail As Outlook.MailItem
'Create New Outlook Email Item to Attach Image(s)
Set OutApp = CreateObject("Outlook.Application")
Set oOutlookEmail = OutApp.CreateItem(0)
'Actual Excel VBA to send email with Embedded images
With oOutlookEmail
.To = "user#gmail.com"
.CC = ""
.BCC = ""
.Subject = "Congrats"
.BodyFormat = olFormatHTML
.Attachments.Add "C:\Users\Username\Pictures\Michael's Email Promotion\Angela.jpg", olByValue, 0
sImgName = "ImageFile.img"
.HTMLBody = "<img src='cid:" & sImgName & "'" & " ><br>" 'Mention only the image file name not its path
'Or Use this below line.
'.HTMLBody = "<img src='" & sImgName & "'" & " ><br>"
.Display
' .Send 'or just put .Display to check
End With
Set OutlookMail = Nothing
Set OutApp = Nothing
End Sub
Sub email()
Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailSig As String
For Each ToCc In ActiveSheet.[A2:A2]
'=============================================================
Dim ToEmail, CcEmail, ToNm, CcNm As String
Dim DescrDt, DescrID, DescrNm As String
ToNm = Cells(ToCc.Row, [C1].Column).Value
CcNm = Cells(ToCc.Row, [G1].Column).Value
ToEmail = Cells(ToCc.Row, [E1].Column).Value
CcEmail = Cells(ToCc.Row, [I1].Column).Value
DescrID = Cells(ToCc.Row, [B1].Column).Value
DescrNm = Cells(ToCc.Row, [D1].Column).Value
DescrDt = "20190426"
'=============================================================
'''determine strBody --email message
Dim strFontSize, strFontName, strFontColor As String
strFontName = "Arial"
strFontColor = fAggieGray
strFontSize = 13
Greeting = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
Application.WorksheetFunction.Proper(ToNm) & "," & "<br> <br>" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>"
emailSig = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
"<br> <br>" & "- OE & HRIS Team" & "<br>" & "______________________" & "<br> <br>" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>" & _
"<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size: 10px;"">" & _
"<span style=""color:" & strFontColor & """>" & _
"[Email generated through Excel Macros and Google meme download - source data: October 3, 2019]" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>"
Set colAttach = oEmail.Attachments
Set oAttach1 = colAttach.Add("C:\Users\AA.jpg")
Set oAttach2 = colAttach.Add("C:\Users\BB.png")
Set oAttach3 = colAttach.Add("C:\Users\CC.jpg")
Set oAttach4 = colAttach.Add("C:\Users\DD.gif")
Set oAttach5 = colAttach.Add("C:\Users\EE.png")
Set oAttach6 = colAttach.Add("C:\Users\FF.jpg")
Set oAttach7 = colAttach.Add("C:\Users\GG.jpg")
Set olkPA1 = oAttach1.PropertyAccessor
Set olkPA2 = oAttach2.PropertyAccessor
Set olkPA3 = oAttach3.PropertyAccessor
Set olkPA4 = oAttach4.PropertyAccessor
Set olkPA5 = oAttach5.PropertyAccessor
Set olkPA6 = oAttach6.PropertyAccessor
Set olkPA7 = oAttach7.PropertyAccessor
olkPA1.SetProperty PR_ATTACH_CONTENT_ID, "AA.jpg"
olkPA2.SetProperty PR_ATTACH_CONTENT_ID, "BB.png"
olkPA3.SetProperty PR_ATTACH_CONTENT_ID, "CC.jpg"
olkPA4.SetProperty PR_ATTACH_CONTENT_ID, "DD.gif"
olkPA5.SetProperty PR_ATTACH_CONTENT_ID, "EE.png"
olkPA6.SetProperty PR_ATTACH_CONTENT_ID, "FF.jpg"
olkPA7.SetProperty PR_ATTACH_CONTENT_ID, "GG.jpg"
oEmail.Close olSave
oEmail.HTMLBody = Greeting & "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
"<br> <br>" & _
"<img src=""cid:FF.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:AA.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:BB.png""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:DD.gif""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:GG.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:EE.png""height=520 width=750>" & _
"</body>"
oEmail.Save
oEmail.To = "MM#email.com"
oEmail.CC = "AA#email.com"
oEmail.Subject = "Congrats " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
oEmail.display
'oEmail.send
NEXT_ToCC:
Set aEmail = Nothing
Set olInsp = Nothing
Set myDoc = Nothing
Set oRng = Nothing
Next ToCc
'oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
If you're using late-binding, then you can't use members of the Outlook OlBodyFormat enum.
olFormatHTML corresponds to 2.
Sub Outlook_Email_With_Inline_Image()
Const olFormatHTML As Long = 2
...
.BodyFormat = olFormatHTML
...
End Sub
Also - add Option Explicit to the top of your module and declare all variables.
I send schedules from Excel every week and I want to convert the data to a table where the week number is one merged cell at the top and the day and date are at the top of each column.
I don't know how to rewrite the mail body message as a table. The code probably has a lot of unnecessary strings but it works. I'd like to add that I am VERY new to VBA, or any coding at all for that matter, and still learning.
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send
End Sub
Sub SendSchedules()
row_number = 2
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim replace_Monday As String
Dim replace_Tuesday As String
Dim replace_Wednesday As String
Dim replace_Thursday As String
Dim replace_Friday As String
Dim replace_Saturday As String
Dim replace_Sunday As String
mail_body_message = ActiveSheet.Range("J1") & vbNewLine & ActiveSheet.Range("C1") & " " & ActiveSheet.Range("C2") & vbNewLine & ActiveSheet.Range("D1") & " " & ActiveSheet.Range("D2") & vbNewLine & ActiveSheet.Range("E1") & " " & ActiveSheet.Range("E2") & vbNewLine & ActiveSheet.Range("F1") & " " & ActiveSheet.Range("F2") & vbNewLine & ActiveSheet.Range("G1") & " " & ActiveSheet.Range("G2") & vbNewLine & ActiveSheet.Range("H1") & " " & ActiveSheet.Range("H2") & vbNewLine & ActiveSheet.Range("I1") & " " & ActiveSheet.Range("I2")
full_name = ActiveSheet.Range("B" & row_number)
mon_day = ActiveSheet.Range("C" & row_number)
tues_day = ActiveSheet.Range("D" & row_number)
wednes_day = ActiveSheet.Range("E" & row_number)
thurs_day = ActiveSheet.Range("F" & row_number)
fri_day = ActiveSheet.Range("G" & row_number)
satur_day = ActiveSheet.Range("H" & row_number)
sun_day = ActiveSheet.Range("I" & row_number)
week_number = ActiveSheet.Range("K2")
mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
mail_body_message = Replace(mail_body_message, "replace_week_number", week_number)
mail_body_message = Replace(mail_body_message, "replace_Monday", mon_day)
mail_body_message = Replace(mail_body_message, "replace_Tuesday", tues_day)
mail_body_message = Replace(mail_body_message, "replace_Wednesday", wednes_day)
mail_body_message = Replace(mail_body_message, "replace_Thursday", thurs_day)
mail_body_message = Replace(mail_body_message, "replace_Friday", fri_day)
mail_body_message = Replace(mail_body_message, "replace_Saturday", satur_day)
mail_body_message = Replace(mail_body_message, "replace_Sunday", sun_day)
MsgBox mail_body_message
Call SendEmail(ActiveSheet.Range("A" & row_number), "Schedule Week 1", mail_body_message)
Loop Until row_number = 12
End Sub
Nothing wrong with this code, but now I want to take this information and create a table out of it. Although I'm worried I need to re-write the entire thing, I'm not sure how.
There are many ways to create tables in excel, but I can only think of two good methods for emailing them.
You could use VBA to setup a temporary excel spreedsheet that formats the table in the correct format. At this point, then you can simple copy and paste the entire thing into an HTML email using VBA.
Or, with VBA you could simply generate your entire body of text using HTML and then send the entire HTML string to your email body.
I have used the HTML route many times, and it can save a ton of time and it is much more useful.
Edit: Here is an example of using HTML, it's pretty rough and I wrote it in my early days. Please note that this was modified from a use-case I have with it. So you might have to tweak it a bit.
Sub Dealer_Email(Sheet As String, Name As Variant, Recipient As Variant, Subject As Variant, _
Mon as Variant, Tues as Variant, Wednesday as Variant, Thurs as Variant, _
Friday as Variant, Optional Copy As String, Optional Blind_Copy As String, _
Optional Attach As String)
' Sheet = the Sheet name in which you wish to pull data from (this was designed for multiple sheets with identical layouts.
'Name = the Name in which will be entered into the generated email
'Recipient = the email address
'Subject = the subject line
'Optional Copy = If you wish to 'cc' someone on the email
'Optional Blind_copy = adds someone to 'bcc' on the email
'Optional attachment = You can define a file to be attached to the email
' Parts of this function came from https://www.rondebruin.nl/
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim x, y As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(Sheet)
strbody = "<table>"
strbody = strbody & _
"<tr>" & _
"<td> | </td>" & _
"<td>" & Mon & "</td>" & _
"<td> | </td>" & _
"<td>" & Tues & "</td>" & _
"<td> | </td>" & _
"<td>" & Wednes & "</td>" & _
"<td> | </td>" & _
"<td>" & Thurs & "</td>" & _
"<td> | </td>" & _
"<td>" & Fri & "</td>" & _
"<td> | </td>" & _
"<td>" & Sat & "</td>" & _
"<td> | </td>" & _
"<td>" & Sun & "</td>" & _
"<td> | </td>" & "</tr></table>"
strbody = "<font>Good Day " & Name & ",<br><br>" & _
"Insert Message Here...<br>" & _
strbody & _
"<br>" & _
"If you have any questions, feel free to contact me.</font>"
2
On Error Resume Next
With OutMail
.Display
.To = Recipient
.CC = Copy
.BCC = Blind_Copy
.Subject = Subject
.htmlbody = strbody & .htmlbody
.Attachment = Attach
End With
OutMail.Display
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Note that this does require Microsoft Outlook to work. Part of this code did come from https://www.rondebruin.nl/.
You could easily add a loop, and have this repeat as needed for each line within the html chart.
EDIT (SECOND TIME AROUND):
Sub SendSchedules()
Dim row_number As Integer
row_number = 2
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim replace_Monday As String
Dim replace_Tuesday As String
Dim replace_Wednesday As String
Dim replace_Thursday As String
Dim replace_Friday As String
Dim replace_Saturday As String
Dim replace_Sunday As String
full_name = ActiveSheet.Range("B" & row_number).Value
mon_day = ActiveSheet.Range("C" & row_number).Value
tues_day = ActiveSheet.Range("D" & row_number).Value
wednes_day = ActiveSheet.Range("E" & row_number).Value
thurs_day = ActiveSheet.Range("F" & row_number).Value
fri_day = ActiveSheet.Range("G" & row_number).Value
satur_day = ActiveSheet.Range("H" & row_number).Value
sun_day = ActiveSheet.Range("I" & row_number).Value
week_number = ActiveSheet.Range("K2").Value
strbody = "<table>"
mail_body_message = strbody & _
"<tr>" & _
"<td> Full Name: </td>" & _
"<td>" & full_name & "</td></tr>" & _
"<tr><td>Week Number: </td>" & _
"<td>" & week_number & "</td></tr>" & _
"<tr><td>Monday: </td>" & _
"<td>" & mon_day & "</td></tr>" & _
"<tr><td>Tuesday: </td>" & _
"<td>" & tues_day & "</td></tr>" & _
"<tr><td>Wednesday: </td>" & _
"<td>" & wednes_day & "</td></tr>" & _
"<tr><td>Thursday: </td>" & _
"<td>" & thurs_day & "</td></tr>" & _
"<tr><td>Friday: </td>" & _
"<td>" & fri_day & "</td></tr>" & _
"<tr><td>Saturday: </td>" & _
"<td>" & satur_day & "</td></tr>" & _
"<tr><td>Sunday: </td>" & _
"<td>" & sun_day & "</td></tr>" & _
"</table>"
MsgBox mail_body_message
Loop Until row_number = 12
You will need to change another line of code from:
olMail.Body = mail_body
to the following.
olMail.htmlbody = mail_body & .htmlbody
I hope this helps out.
I have to create a VBA to send automatic e-mails (the body of the e-mail links the recipient to a specific project that he is responsible for). The problem that I encountered is the fact that a certain recipient (i.e. placed in "TO") can be responsible for more tasks. The VBA that I am using sends emails to each task (even if the person is responsible for more). What can I do to count through recipients, if it's greater than 1 to send the e-mail which includes all of the tasks. I really need your help.
<PRE>Sub SendEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim lastRow As Long
Dim Ebody As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Ebody = "<FONT SIZE = 4 name = Arial>" & "Dear " & Cells(i, "A").Value
& "<br>" _
& "<br>" _
& "Please note that the below mentioned projectd are in scope for reporting." & "<br>" _
& "<br>" _
& Cells(i, "C").Value & " - " & Cells(i, "E").Value & "<br>" _
& "xxxxx will investigate and action your notification according to priority and to ensure public safety." & "<br>" _
& "For further information, please phone xxxxx on 6111 and quote reference number:" & "<br>" _
& "Your original report can be seen below:" & "</Font>" & "<br>" _
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Cells(i, "B").Value
.Cc = Cells(i, "D").Value
.Subject = "Your Registration Code"
.HtmlBody = Ebody
.Attachments.Add "C:\Test\Document.docx"
.Attachments.Add "C:\Test\Document1.docx"
.SentOnBehalfOfName = "Financial#yahoo.com"
.Display
End With
Next
End Sub </pre>
Sub Emailer()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, y, sbody
Dim eml As Worksheet, bd As Worksheet
Dim underlyingary, ISINarray, Accountarray, i
Set eml = Sheets("Emailer"): Set bd = Sheets("Body"): Set OutApp = CreateObject("Outlook.Application")
For Each y In eml.Range("A2:A" & eml.Range("A1000000").End(xlUp).Row)
If eml.Range("F" & y.Row) <> "" Then
underlyingary = Split(eml.Range("F" & y.Row), ",")
Accountarray = Split(eml.Range("G" & y.Row), ",")
ISINarray = Split(eml.Range("H" & y.Row), ",")
For i = 0 To UBound(underlyingary)
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(underlyingary(i))) & " Account Number: " & WorksheetFunction.Proper(Trim(Accountarray(i))) & " ISIN: " & WorksheetFunction.Proper(Trim(ISINarray(i))) & "<br>" & "<br>"
Next i
Else
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(eml.Range("C" & y.Row))) & " Account Number: " & WorksheetFunction.Proper(Trim(eml.Range("D" & y.Row))) & " ISIN: " & WorksheetFunction.Proper(Trim(eml.Range("E" & y.Row))) & "<br>"
End If
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = eml.Range("A" & y.Row)
.Subject = bd.Range("B2")
.cc = eml.Range("I" & y.Row)
.htmlBody = bd.Range("A2") _
& "<br>" & "<br>" & _
bd.Range("A3") & _
Trim(eml.Range("B" & y.Row)) & _
bd.Range("A4") _
& "<br>" & "<br>" & _
sbody _
& "<br>" & _
bd.Range("A5") _
& "<br>" & "<br>" & "<li>" & _
bd.Range("A6").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A7").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A8").Text & "</li>" & _
"<br>" & "<br>" & _
bd.Range("A9") _
& "<br>" & bd.Range("A10")
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Next y
cleanup:
Set OutApp = Nothing
End Sub