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
Related
I'm trying to automate creation of an email with a user required to press Send so it can be checked. I can get the mail item created with a 'To' list and such, however when I try to add an attachment I get an error.
Sub EmailReportX(ByVal MailTo As String, AttachFilename As String, AttachFilePath As String, SubjectDate As String)
Dim objOutlook As Object
Dim objMailItem As Object
Dim strAtt As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
strAtt = AttachFilePath & AttachFilename
With objMailItem
.To = MailTo
.Subject = "Seymour Horst Daily Completions Report " & SubjectDate
.body = "Morning," & vbCrLf & vbCrLf & "Daily completions report for review" & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & "Tim C"
.Attachments.Add = strAtt
.display
End With
Debug.Print strAtt
End Sub
.Attachments.Add() is a method and thus does not require the equals sign.
https://learn.microsoft.com/en-us/office/vba/api/outlook.attachments.add
so use it like this.
With objMailItem
.To = MailTo
.Subject = "Seymour Horst Daily Completions Report " & SubjectDate
.body = "Morning," & vbCrLf & vbCrLf & "Daily completions report for review" & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & "Tim C"
.Attachments.Add strAtt
.display
End With
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 want to create a button that saves a worksheet in pdf format, Attaches to a new mail and send it.
i can create the pdf, save the pdf on my desktop, create and e-mail. but the PDF is never attached. Where am I going wrong?
Dim pdfName As String
pdfName = PONumberLabel.Caption ' add PO number on label to a variable
' create pdf and save to desktop
ChDir "C:\Users\roanderson\Desktop" ' selects directory to save
Sheet4.ExportAsFixedFormat _
Type:=xlTypePDF, _
OpenAfterPublish:=True, _
Quality:=xlQualityStandard, _
Filename:="C:\Users\roanderson\Desktop\" & pdfName ' directory put t
' sending email for approval
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Please approve PO Number" & " " & PONumber & vbNewLine & vbNewLine & _
"Cost Centre:" & " " & costcentre & vbNewLine & _
"Description:" & " " & description & vbNewLine & _
"Currency:" & " " & POCurrency & vbNewLine & _
" Total:" & " " & total
On Error Resume Next
With xOutMail
.To = "Ross.anderson#work.com"
.CC = ""
.BCC = ""
.Subject = "PO Number " & PONumber & " " & "Approval"
.Body = xMailBody
.Display 'or use .Send
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName
.VotingOptions = "Accept;Reject"
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Everything works except attaching pdf to email.
Change the Statement
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName
To
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName & ".pdf"
As it seems like pdfname does not have the full name with Extension.
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
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