I'm attempting to add attach a file to an email created from a template. The idea is to be able to use the File Picker to select multiple files and excel sends an email to the proper recipients with the correct attachments.
The problem is that I cannot use the ".Display" method without getting an error and I want to review the email before sending so I do not want to use ".Send".
However, for whatever reason, if I clear the email template body with ".Body = ''", I am able to Display the email and attach the correct file. I'd like to keep the email body from the template as is though without clearing it and rewriting it.
So it seems that I cannot use an email template if I want to first display before sending? Has anyone ever had this problem or know how to solve?
The Error message is:
'-2147221233(8004010f)' The attempted operation failed. An object could not be found.
Btw, most of the variables are declared globally so that is why they are not visible.
Dim Agency As String
Dim xfullName As Variant
Dim Template As String
Dim mail As Outlook.mailItem
Dim myOlApp As Outlook.Application
Dim selectedFile As Variant
Dim emailBody As String
Dim emailType As String
Dim recipients As String
Sub Recall_Email()
Dim fileName As String
Dim inputFile As FileDialog
Set myOlApp = CreateObject("Outlook.Application")
Set inputFile = Application.FileDialog(msoFileDialogFilePicker)
Template = "C:\Users\me\AppData\Roaming\Microsoft\Templates\Recall Templates\Recall Template.oft"
With inputFile
.AllowMultiSelect = True
If .Show = False Then Exit Sub
End With
For Each selectedFile In inputFile.SelectedItems
xfullName = selectedFile
fileName = Mid(inputFile.SelectedItems(1), InStrRev(inputFile.SelectedItems(1), "\") + 1, Len(inputFile.SelectedItems(1)))
Agency = Left(fileName, 3)
CreateTemplate(Template)
Next selectedFile
End Sub
Private Sub CreateTemplate(temp)
Set myOlApp = CreateObject("Outlook.Application")
Set mail = myOlApp.CreateItemFromTemplate(temp)
Set olAtt = mail.Attachments
With mail
'.Body = "" -- If I use this line, everything attaches
.Subject = Agency & " Recall File"
.To = "email"
.Attachments.Add xfullName
.Display '.Send
End With
End Sub
Here is a working example on how to attach or embed files to outlook.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Related
I'm trying to attach three sheets to an email to be sent to a certain email address with a certain subject and content.
I currently attach each sheet in the workbook to an email each.
The two problems I'm looking to solve -
It currently cycles through all sheets, I want to attach sheets labeled "Account", "Subscription", "Users" so I can have another sheet for instructions.
Can I get attach all three to a single email? My research so far has come up blank.
I tried using something like the below, but that created errors in other areas that I don't know.
For Each ws In Sheets(Array("Account", "Subscription", "Users"))
Sub COMEON()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream, fil As String
Dim dummy As Workbook
Dim var As String
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ActiveWorkbook.Worksheets
Dim StrBody As String
StrBody = " THIS IS A TEST" & " " & UCase(oneSheet.Name) & " " & "XYZ," & vbNewLine & _
vbNewLine & _
"Please FIND ATTACHED <B>'XYZ REPORT'<B>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.htmlBody = StrBody & htmlBody
.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
.Display
.Subject = var & " - " & UCase(oneSheet.Name) & " CSV " & "(" & Today & ")"
End With
Next oneSheet
End Sub
Should be close:
Sub COMEON()
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim dummy As Workbook
Dim var As String
Dim StrBody As String, arrSheets, Today
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set outlookApplication = CreateObject("Outlook.Application")
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.bodyformat = 1 'HTML
.Subject = var & " - CSV " & "(" & Today & ")"
.Display
End With
StrBody = "THIS IS A TEST<br><br>Files: <ul>"
arrSheets = Array("Account", "Subscription", "Users")
For Each oneSheet In dummy.Worksheets
If Not IsError(Application.Match(oneSheet.Name, arrSheets, 0)) Then
StrBody = StrBody & "<li>" & oneSheet.Name & "</li>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
'add attachment
outlookMail.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
End If 'want this sheet
Next oneSheet
With outlookMail
.htmlBody = StrBody & "</ul>" & .htmlBody
End With
End Sub
Basically move stuff out of the loop that doesn't need to be there.
I'm trying to send an email with the body of the message consisting of the contents of a text box. So far I've tried pulling in the text box through vba as a string, but that takes away all the new-lines formatting. Is there a way to get the text box contents exactly as they are into the email?
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim title As String, emailto As String
Dim texts As String
title = Range("email_subject").Value
emailto = Range("email_to").Value
texts = Worksheets("Input").Shapes("TextBox 2").TextFrame.Characters.Text
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emailto
.Subject = title
.HTMLBody = texts
.display
End With
On Error GoTo 0
End Sub
Please find an example below that might help with your question. You will have global variable that will hold information from excel worksheet and use them in the email. Whithout a image on how your data looks cannot really guess what you are trying to do. Maybe you can separete the text in different cells that way you can loop throught and put them in different variables and you can construct your email in the SendEmail procedure. Or if you have the same text and it doesn't change you can make it as per the below example.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Hi I am using below code to add chart and send email to multiple recipients. It works fine. In my sent item i can see a perfect email created and sent. But all the recipients are not able to see the charts. All they see is two red X
Sub Send_Email_Updated()
Dim olApp As Object
Dim NewMail As Object
Dim NewMail1 As Object
Dim ChartName As String
Dim ChartName1 As String
Dim SendingRng As Range
Dim htmlString As String
Dim OMail As Outlook.MailItem
Set wb = ActiveWorkbook
Set S1 = wb.Worksheets("Incident Tickets")
Set S2 = wb.Worksheets("Assets and Representatives")
Set S3 = wb.Worksheets("Email")
'Set SendingRng = Worksheets("Email").Table("A30:C43")
Set SendingRng = Worksheets("Email").Range("A30:C43")
Set olApp = CreateObject("Outlook.Application")
Set OMail = olApp.CreateItem(olMailItem)
' Group 1
If S3.Cells(7, 2) <> 0 Or S3.Cells(8, 2) <> 0 Or S3.Cells(9, 2) <> 0 Then
OMail.Display
'fill in the file path/name of the gif file app graph
ChartName = Environ$("Temp") & "\Chart 1.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 1").Chart.Export _
Filename:=ChartName, FilterName:="GIF"
'fill in the file path/name of the gif file trend graph
ChartName1 = Environ$("Temp") & "\Chart 31.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 31").Chart.Export _
Filename:=ChartName1, FilterName:="GIF"
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Action Required on Incidents and Problem Candidates for GC060.1 - Group 1"
.To = "animesh.das#xyz.com"
.HTMLBody =
"<img src=" & "'" & ChartName1 & "'>" & "<br/>" & "<br/>" & "_
"<img src=" & "'" & ChartName & "'>" & "<br/>" & "<br/>" & _
.Send
End With
ChartName = vbNullString
ChartName1 = vbNullString
End If
End Sub
My table is structured as:
Vendor Consultor CLIENT Date OS Status
test#test.com Andrew NAME 1 25/12/2017 123456 Pend
test#test.com Andrew NAME 2 31/12/2017 789123 Pend
test134#test.com Joseph NAME 3 10/12/2017 654321 Pend
I need to consolidate everything that is pending for the seller "Andrew or Joseph" and send a single email with the "OS" list.
I am using the following code but unsuccessful as it opens a new email for each row of the worksheet:
Sub email()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For i = 1 To Range("C5536").End(xlUp).Row
Set OutMail = OutApp.CreateItem(0)
strto = Cells(i, 1)
strsub = "OS - PENDING"
strbody = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf & _
"Consultor:" & Cells(i, 3) & vbCrLf & _
"Date:" & Cells(i, 4) & vbCrLf & _
"OS:" & Cells(i, 5) & vbCrLf & vbCrLf & _
"Best Regards" & vbCrLf & _
"Team"
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Display
End With
On Error Resume Next
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Create a class cVendorline with the following code
Option Explicit
Private mClient As String
Private mDate As Date
Private mOS As String
Public Property Get Client() As String
Client = mClient
End Property
Public Property Let Client(ByVal bNewValue As String)
mClient = bNewValue
End Property
Public Property Get dDate() As Date
dDate = mDate
End Property
Public Property Let dDate(ByVal bNewValue As Date)
mDate = bNewValue
End Property
Public Property Get OS() As String
OS = mOS
End Property
Public Property Let OS(ByVal sNewValue As String)
mOS = sNewValue
End Property
Then put the following code into a module and run Consolidate
Option Explicit
Sub Consolidate()
#If Early Then
Dim emailInformation As New Scripting.Dictionary
#Else
Dim emailInformation As Object
Set emailInformation = CreateObject("Scripting.Dictionary")
#End If
GetEmailInformation emailInformation
SendInfoEmail emailInformation
End Sub
Sub GetEmailInformation(emailInformation As Object)
Dim rg As Range
Dim sngRow As Range
Dim emailAddress As String
Dim vendorLine As cVendorLine
Dim vendorLines As Collection
Set rg = Range("A1").CurrentRegion ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1) ' Cut the headings
For Each sngRow In rg.Rows
emailAddress = sngRow.Cells(1, 1)
Set vendorLine = New cVendorLine
With vendorLine
.Client = sngRow.Cells(1, 3)
.dDate = sngRow.Cells(1, 4)
.OS = sngRow.Cells(1, 5)
End With
If emailInformation.Exists(emailAddress) Then
emailInformation.item(emailAddress).Add vendorLine
Else
Set vendorLines = New Collection
vendorLines.Add vendorLine
emailInformation.Add emailAddress, vendorLines
End If
Next
End Sub
Sub SendInfoEmail(emailInformation As Object)
Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant
sBodyStart = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf
For Each emailAdress In emailInformation
Set colLines = emailInformation(emailAdress)
sBodyInfo = ""
For Each line In colLines
sBodyInfo = sBodyInfo & _
"Consultor:" & line.Client & vbCrLf & _
"Date:" & line.dDate & vbCrLf & _
"OS:" & line.OS & vbCrLf
Next
sBodyEnd = "Best Regards" & vbCrLf & _
"Team"
sBody = sBodyStart & sBodyInfo & sBodyEnd
SendEmail emailAdress, "OS - PENDING", sBody
Next
End Sub
Sub SendEmail(ByVal sTo As String _
, ByVal sSubject As String _
, ByVal sBody As String _
, Optional ByRef coll As Collection)
#If Early Then
Dim ol As Outlook.Application
Dim outMail As Outlook.MailItem
Set ol = New Outlook.Application
#Else
Dim ol As Object
Dim outMail As Object
Set ol = CreateObject("Outlook.Application")
#End If
Set outMail = ol.CreateItem(0)
With outMail
.To = sTo
.Subject = sSubject
.Body = sBody
If Not (coll Is Nothing) Then
Dim item As Variant
For Each item In coll
.Attachments.Add item
Next
End If
.Display
'.Send
End With
Set outMail = Nothing
End Sub
I would like to modify this script to include an attachment in the email that it creates. Cell F5 on worksheet "Instructions" contains the file path. I've tried to modify it using information from several different sources.
Here is a working version, pre-attachment attempts:
Sub CreateMails()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As String
Dim rngAttach As Range
Dim SigString As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Worksheets("Data validation")
Set rngTo = .Range("J63")
Set rngSubject = .Range("J61")
strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"__________________________________" & vbNewLine & _
.Range("J67") & vbNewLine & vbNewLine & _
"My Company" & vbNewLine & _
"123 Address street" & vbNewLine & _
"City, State, Zip, USA" & vbNewLine & _
"Telephone:"
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.Save
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set strbody = Nothing
Set rngAttach = Nothing
End Sub
All you should need is:
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.attachments.Add Range("F5").Value 'add the attachment
.Save
End With
Using your code, this worked for me.
Hi I can share the below template code which i use for creating and attaching a sheet from my workbook as a PDF _ i've changed some of the "text" values but the rest is the same.
You could work with this to include the attachment, and send as xlsx if required.
Sub SendWorkSheetToPDF()
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet
Dim cell As Range
Dim strto As String
Dim Strcc As String
Application.ScreenUpdating = False
'To'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
If cell.Value Like "?*#?*.?*" Then
Strcc = Strcc & cell.Value & ";"
End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next
Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
"Please see attached daily " & vbNewLine & vbNewLine & _
"Kind Regards" & vbNewLine & _
" "
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub