Automatic e-mail with changes in the body - VBA - excel

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

Related

Extract CurrentRegion into email body

CurrentRegion is extracted but not shown in email body
Sub Draft()
Dim myDataRng As Range
Set myDataRng = Range("c2:c2")
Dim data As String
data = Range("B11").CurrentRegion.Select
For Each Cell In myDataRng
If Cell.Value > 0 Then
Dim objOutlook As Object
Set objOutlook = CreateObject("outlook.application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Range("K2").Select
With objEmail
.SentOnBehalfOfName = "accounting#test.co.uk"
.to = ActiveCell.Offset(0, 1).Value
.Subject = ActiveCell.Offset(7, 0).Value
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" & "A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
.Save
End With
Set objOutlook = Nothing
End If
Next Cell
Set myDataRng = Nothing
Set objEmail = Nothing: Set objOutlook = Nothing
MsgBox "Please check pyament advice in your draft folder!"
End Sub
The final outcome is like this.
Dear Supplier,
A payment has been issued to you, as detailed below.
True
Kind Regards,
Johnny Grif
Accounts Assistant/Accounts Department
T:+44(0)1234 567 890
E:accounting#test.co.uk
Below is the output:
The following code is the cause of the problem:
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" &
"A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
First of all, the message body markup should be represented by a well formed HTML document/string.
Second, if you need to break the line in the code you need to use the underscore _ character in the code to get the lines assembled correctly.
Third, I'd suggest breaking the code and trying to assemble the final from multiple pieces, so you could find out why the code doesn't work correctly.

Bulk Email - Cannot show Signature Logo in email [duplicate]

The below code embeds the photo but doesn't display because
"The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location."
I know the file path is correct.
Sub mail()
Dim Sig As String
Set myOlApp = CreateObject("Outlook.Application")
LR400 = Columns(1).Find("*", SearchDirection:=xlPrevious).Row
sPath = Environ("appdata") & "\Microsoft\Signatures\Amir Higgs.txt"
For x = 2 To LR400
If Cells(x, 2) <> "no email" Then
emails = Cells(x, 1)
'TheBody1 = "The Parallon Workforce Team" & vbCrLf & vbCrLf & vbCrLf & _
"Amir Higgs" & vbCrLf & _
"Accounts Payable Clerk" & vbCrLf & _
"Parallon Workforce Solutions" & vbCrLf & _
"1000 Sawgrass Corporate Pkwy, 6th Floor" & vbCrLf & _
"Sunrise, FL 33323" & vbCrLf & _
"P: 954-514-1656" & vbCrLf & _
"www.parallon.com"
Set myitem = myOlApp.CreateItem(olMailItem)
With myitem
.SentOnBehalfOfName = "PARA.WFAdjustments#Parallon.com"
.To = Cells(x, 2)
.Subject = Cells(x, 3)
.Body = TheBody1
'.CC = ""
.Attachments.Add emails
.Attachments.Add "C:\Users\JoeSchmo\Pictures\WF Communications.jpg", olByValue, 0
.HTMLBody = "<BODY><IMG src=""cid:WF Communications.jpg"" width=200> </BODY>"
.display
End With
End If
Next x
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Change your JPG file name to one word Example WF_Communications.jpg or WFCommunications.jpg
.Attachments.Add "C:\Users\JoeSchmo\Pictures\WF_Communications.jpg", olByValue, 0
.HTMLBody = "<BODY><IMG src=""cid:WF_Communications.jpg"" width=200> </BODY>"

Unable to send email using shared mailbox from Excel VBA

I have about 35 files that I run daily, all of which send their own email to a different distribution list, depending on which report is being sent, and all from a shared email account which has been added to my Outlook. I have 2 files that, for some odd reason, will not send from the shared email account I need to use.
**Edit: To clarify, the code runs to completion, and I can see the email open and disappear quickly, as if the email DID send. But nothing sends and no email shows in that account's sent items.
I have added the Microsoft Outlook 16.0 Object Library in my references, and all files are essentially using the same code:
Public Sub sendEmail()
Dim OutLookApp As Object, oAccount As Outlook.Account
Dim OutLookMailItem As Object
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
For i = 1 To Outlook.Application.Session.Accounts.Count
Set oAccount = OutLookApp.Session.Accounts.Item(i)
If oAccount = "notmypersonalaccount#xxx.com" Then Exit For
Next
With OutLookMailItem
Set .SendUsingAccount = OutLookApp.Session.Accounts.Item(i)
.To = "user1; user2; user3; user4; user5; " _
& "user6; user7; user8; user9; user10; user11; " _
& "user12; user13; user14; user15; user16; " _
& "user17; user18; user19; user20; user21; user22"
.CC = "user23; user24; user25"
.BCC = ""
.Subject = "Queue Inquiry for " & Format(Now, "m/d/yyyy") & ":"
.Display
.HTMLBody = "<BODY style=font-size:11pt;font-family:Cambria>Good Morning, " & "<br>" & "<br>" & _
"Please follow the link below to view the Queue Inquiry Report for " & Format(Now, "m/d/yyyy") _
& ". Below are the queue listings applicable for each area. This report will show you the volume in each queue and is sorted by oldest referral date (to help manage SLAs/Production)." _
& "<br>" & "<br>" & "Fraud Queues" & "<br>" & "- JPF" & "<br>" & "- PFR" & "<br>" & "<br>" _
& "C/S Back Office" & "<br>" & "- LBX" & "<br>" & "- SCK" & "<br>" & "- WSN" & "<br>" & "- TCR" & "<br>" & "- FIC" & "<br>" & "<br>" _
& "Dispute Resolution" & "<br>" & "- CS1" & "<br>" & "- APP" & "<br>" & "- RDP" & "<br>" & "- RTV" & "<br>" & "<br>" _
& "Credit Bureau Disputes" & "<br>" & "- CBD" & "<br>" & "<br>" _
& "Credit Back Office" & "<br>" & "- LTQ" & "<br>" & "<br>" _
& "Collections" & "<br>" & "- MGR" & "<br>" & "<br>" _
& "Bankruptcy" & "<br>" & "- LD7" & "<br>" & "- MM4" & "<br>" & "<br>" _
& "xxxxx xxxxx</BODY>" & .HTMLBody
.Send
End With
End Sub
What I don't get is that this file was working yesterday, before I added 6 new people to the distro list, user17 through user22. If I comment out the .SendUsingAccount = OutLookApp.Session.Accounts.Item(i) I am able to send using my email account.
Any thoughts?
Some changes that may make the code more reliable.
Option Explicit
Public Sub sendEmail()
Dim OutLookApp As Object
Dim oAccount As Outlook.account
Dim OutLookMailItem As Object
Dim srchAccount As String
Dim i As Long
Dim foundFlag As Boolean
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
srchAccount = "notmypersonalaccount#xxx.com"
For i = 1 To Session.Accounts.Count
Set oAccount = Session.Accounts.Item(i)
Debug.Print oAccount
If oAccount = srchAccount Then
foundFlag = True
Exit For
End If
Next
If foundFlag = True Then
With OutLookMailItem
Set .SendUsingAccount = oAccount
' without a subsequent .Send you can see the mail
.Display
End With
Else
MsgBox srchAccount & " not found."
End If
End Sub
To remove Excel from possible causes.
Option Explicit
Public Sub sendEmail_NotFromExcel()
Dim oAccount As account
Dim OutLookMailItem As Object
Dim srchAccount As String
Dim i As Long
Dim foundFlag As Boolean
Set OutLookMailItem = CreateItem(olMailItem)
srchAccount = "notmypersonalaccount#xxx.com"
For i = 1 To Session.Accounts.count
Set oAccount = Session.Accounts.Item(i)
Debug.Print oAccount
If oAccount = srchAccount Then
foundFlag = True
Exit For
End If
Next
If foundFlag = True Then
With OutLookMailItem
Set .SendUsingAccount = oAccount
.Display
End With
Else
MsgBox srchAccount & " not found."
End If
End Sub

Input cell data from Excel into Outlook

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

Trying to generate email from data in Excel spreadsheet, getting compile error "User defined type not defined"

I'm trying to generate an email from data input on to a spreadsheet, to create an offer of work. But when I do, I keep getting the same error: Compile error, user-defined type not defined
I've gone into "Tools" > References and ticked the "Microsoft Outlook 16.0 Object Library" checkbox, but I get the same error. When I'm trying to search for other answers on this subject, this seems to be the solution for most.
Option Explicit
Private Sub Generate_offer()
Dim strFile As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
With objOutlookMsg
.SentOnBehalfOfName = ""
.To = ""
.Subject = "xxxxxxxx"
.Body = "Dear " & vbNewLine & vbNewLine & "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "C").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "J").Value & " - " & Cells(ActiveCell.Row, "K").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "M").Value & "xxxxxxxx" & vbNewLine _
& "Notes: " & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine & "xxxxxxxx"
.display
End With
'objOutlookMsg.Send
Set OutApp = Nothing
End Sub
Any help much appreciated.
Your code is using 'Early Binding'.. where in order to use Dim Something As Outlook.Something, Excel needs to have the Outlook Library referenced.
You have two options.
You can rectify this by either
Adding the reference -
In the VB Editor window, ensuring the code execution is halted entirely, go to Tools > References and tick Microsoft Outlook x.x Object Library (x.x will depend on the version you have installed).
Or use late binding - which keeps the declarations open (as objects) that get bound as you use them:
Option Explicit
Private Sub Generate_offer()
Dim strFile As String
Dim OutApp As Object
Dim objOutlookMsg As Object
Dim olMailItem As Long
olMailItem = 0 ' (0 = Mail item, 1 = Appointment, 2 = Contact etc..)
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
With objOutlookMsg
.SentOnBehalfOfName = ""
.To = ""
.Subject = "xxxxxxxx"
.Body = "Dear " & vbNewLine & vbNewLine & "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "C").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "J").Value & " - " & Cells(ActiveCell.Row, "K").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "M").Value & "xxxxxxxx" & vbNewLine _
& "Notes: " & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine & "xxxxxxxx"
.display
End With
'objOutlookMsg.Send
Set OutApp = Nothing
End Sub
Note - the main reason I'd use Late Binding would be if the macro is going to be used on multiple machines with different Excel versions installed. If Early Binding is used and the reference is pointing at a specific version that isn't installed, you'll get an error. Late Binding will find any version that provides Outlook.
I get no errors when changing your Dim to Objects
Option Explicit
Private Sub Generate_offer()
Dim strFile As String
Dim OutApp As Object
Dim objOutlookMsg As Object
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(0)
With objOutlookMsg
.SentOnBehalfOfName = ""
.To = ""
.Subject = "xxxxxxxx"
.Body = "Dear " & vbNewLine & vbNewLine & "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "C").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "J").Value & " - " & Cells(ActiveCell.Row, "K").Value & vbNewLine _
& "xxxxxxxx" & Cells(ActiveCell.Row, "M").Value & "xxxxxxxx" & vbNewLine _
& "Notes: " & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine _
& "xxxxxxxx" & vbNewLine & vbNewLine & "xxxxxxxx"
.display
End With
'objOutlookMsg.Send
Set OutApp = Nothing
End Sub

Resources