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.
Related
I am using a macro to compose a report based on an excel file. The macro uses a body with text and a picture (png) from an predefined Excel range.
This used to work perfect but now I have to share the report outside of my organization i get feedback that the image is not showing.
Does anybody know if this is due to the macro or not?
I have tested this also to my hotmail and gmail accounts and it is not showing there as well?
Sub Mail_()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim Adm As Worksheet
Dim Body As String
Dim Body2 As String
Dim Body3 As String
Dim Body4 As String
Dim rngToPicture As Range
Dim rng2 As Range
Dim Weeknr As String
Dim strTempFilePath As String
Dim strTempFileName As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set Adm = ActiveWorkbook.Worksheets("Uit")
Set rngToPicture = Adm.Range("X13:AT65")
Adm.Activate
ActiveWindow.Zoom = 100
strTempFileName = "RangeAsPNG"
Weeknr = Adm.Range("AF3").Text
Body = Adm.Range("X6:X6").Text
Body2 = Adm.Range("X8:X8").Text
Body3 = Adm.Range("X9:X9").Text
Body4 = Adm.Range("X11:X11").Text
strbody = "<BODY style=font-size:10pt;font-family:Verdana>" & Body & _
"<br><br>" & Body2 & "<br>" & Body3 & "<br><br>" & Body4 & "<br><br>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Handtekeningen\Servicekantoor.htm"
Signature = GetBoiler(SigString)
On Error Resume Next
With OutMail
.to = "Mailinglist#list.com"
.CC = ""
.BCC = ""
.Subject = "Weekly report " & Weeknr
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
.HTMLBody = strbody & "<br><br>" & "<img src='cid:" & strTempFileName & ".png'
style='border:0'>" & "<br><br>" & Signature
.Recipients.ResolveAll
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You are close - the cid in the src attribute must be not the file name (which is not visible to the outside users), but some value that matches the PR_ATTACH_CONTENT_ID property on the attachment:
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
set Attach = .Attachments.Add(strTempFilePath, olByValue)
Attach.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001F", "MyCid"
.HTMLBody = strbody & "<br><br>" & "<img src='cid:MyCid' style='border:0'>" & "<br><br>" & Signature
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
I am not able to filter the selected mail item by Subject.
The issue is that
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then
is triggering the error
Run time error 438: Object doesn't support this property or method.
Steps:
Loop through cells for different subject names
Search the inbox and Sentitem folders for the latest email for selected "Subject" as sometimes people do not respond to your email. So latest email is in the sent items and not in your inbox
select the latest email and reply to all
For the body of the email, I am running another function to get the required info.
The code:
Sub AccessInbox6()
'Early binding
Dim Olook As Outlook.Application ' to access all the libraries of outlook
Set Olook = New Outlook.Application
Dim sFilter As String
Dim sSubject As String
' Restrict items and running the loop
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" 'Using this to loop over multiple cells containing subjects
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Dim Items As Outlook.Items
Set Items = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderInbox).Items 'Checking the inbox
Dim Items2 As Outlook.Items
Set Items2 = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderSentMail).Items 'Checking the sent items
Items.Sort "ReceivedTime", True 'to put them in order by date
Items2.Sort "ReceivedTime", True 'to put them in order by date or I should use "SentOn"
'Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then 'Here I am checking which email is latest by date either in inbox or SentItems
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then 'Getting error here - Here I am checking if the "Subject of the email matches with what I have in the excel sheet
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2(1) Is Outlook.MailItem And Items2(1).Restrict(sFilter) Then
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Function GetPSMUpdate2() As String
Dim PSMColumn As Range, PSMRow As Range, r As Range, C As Range
Dim Str As String
Sheet2.Activate
Set PSMColumn = Range("A2", Range("A1").End(xlDown))
For Each r In PSMColumn
Set PSMRow = Range(r, r.End(xlToRight))
For Each C In PSMRow
Str = Str & C.Value
If C.Column < r.End(xlToRight).Column Then
Str = Str & vbTab
End If
Next C
If r.Row < Range("A1").End(xlDown).Row Then
Str = Str & vbNewLine
End If
Next r
GetPSMUpdate2 = Str
End Function
Use of Item in the variable names causes some confusion as well the filter could be separated.
Option Explicit
Sub AccessInbox6Fix()
'Early binding
Dim Olook As outlook.Application
Dim ItemsRaw As outlook.Items
Dim Items2Raw As outlook.Items
Dim Items As outlook.Items
Dim Items2 As outlook.Items
Dim sFilter As String
Dim sSubject As String
Set Olook = New outlook.Application
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" ' Loop over cells containing subjects
'Checking the inbox
Set ItemsRaw = Olook.Session.GetDefaultFolder(olFolderInbox).Items
Debug.Print "Raw counts"
Debug.Print " ItemsRaw.Count: " & ItemsRaw.Count
'Checking the sent items
Set Items2Raw = Olook.Session.GetDefaultFolder(olFolderSentMail).Items
Debug.Print " Items2Raw.Count: " & Items2Raw.Count
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Debug.Print
Debug.Print sFilter
Debug.Print "Subject counts"
Set Items = ItemsRaw.Restrict(sFilter)
Debug.Print " Items.Count: " & Items.Count
Set Items2 = Items2Raw.Restrict(sFilter)
Debug.Print " Items2.Count: " & Items2.Count
Items.Sort "SentOn", True
Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then
If TypeOf Items.Item(1) Is MailItem Then
Debug.Print Items.Item(1).Subject
With Items.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2.Item(1) Is outlook.MailItem Then
Debug.Print Items2.Item(1).Subject ' Print on Immediate Window
With Items2.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
Debug.Print "Done."
End Sub
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
I am attempting to send an e-mail using a pathway variable in .Attachments.Add, but the e-mail is not including the attachments. When I just add the actual pathway after .Attachments.Add, without the variables (shown below), the e-mail includes the attachments.
.Attachments.Add "C:\Users\id\Desktop\file_name.xlsx"
The method of attaching workbooks (using pathway variables) worked once, but now the workbooks are not attaching for some reason. Being that the string from the pathway variable and the actual pathway are the same, what would cause the workbooks to not attach when using a variable? Below is my code...
The two parameters (title1 and title2) are the workbook titles.
Sub Mail_Workbook_Comb1(ByVal title1 As String, ByVal title2 As String)
Dim OutApp As Object
Dim OutMail As Object
Dim id As String
Dim path1 As String
Dim path2 As String
Dim rnge As Range
Dim sht As Excel.Worksheet
Dim wdoc As Word.Document
Dim distroRnge As Range
id = LCase(workbooks("Supplier_Automation.xlsm").Sheets("Home").Range("C3"))
path1 = "C:\Users\" & id & "\Desktop\" & title1 & ".xlsx"
path2 = "C:\Users\" & id & "\Desktop\" & title2 & ".xlsx"
MsgBox path1
MsgBox path2
Set distroRnge = workbooks("Supplier_Automation.xlsm").Sheets("Distros").Range("A29")
Set sht = workbooks("Supplier_Automation.xlsm").Sheets("Email Template")
Set rnge = sht.Range("B1:B19")
rnge.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set wdoc = OutMail.GetInspector.WordEditor
On Error Resume Next
With OutMail
.To = myname#email.com
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.body = ""
.Attachments.Add path1
.Attachments.Add path2
wdoc.Range.PasteAndFormat Type:=wdChartPicture
With wdoc
.InlineShapes(1).Height = 345
End With
.display 'or use .Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
While the title1 and title2 parameters were passing the workbook titles, I realized that they were not including the date that was being added to the workbook prior to the Mail_Workbook_Comb1 Sub being called. I ended up adding a date variable to the end of the path variable string and that allowed the path variable to match what was saved on my desktop
Dim edate As String
Dim today As String
today = Date
edate = Format(DateAdd("d", -1, today), "mmdd")
id = LCase(workbooks("Supplier_Automation.xlsm").Sheets("Home").Range("C3"))
path1 = "C:\Users\" & id & "\Desktop\" & title1 & " " & edate & ".xlsx"
path2 = "C:\Users\" & id & "\Desktop\" & title2 & " " & edate & ".xlsx"
path3 = "C:\Users\" & id & "\Desktop\" & title3 & " " & edate & ".xlsx"