I am trying to send bulk email via Outlook with two attachments (one logo and one picture of a signature).
When I .send the images don't show in the received email.
They do show, if I first use .display then send manually.
Sub GenerateEMail()
'set abbreviations for workbook and sheets
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsInput As Worksheet: Set wsInput = wb.Sheets("Input")
Dim wsTool As Worksheet: Set wsTool = wb.Sheets("Tool")
Dim outObj As Object
Dim Mail As Object
Set outObj = CreateObject("Outlook.Application")
'Dim olkPA As Outlook.PropertyAccessor
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
'Fasten Macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'get information from sheet "Tool"
'E-Mail
Subject = wsTool.Range("Subjet").Value
Text = wsTool.Range("Text").Value
'Signatures
Signature = wsTool.Range("Sig").Value & "\" & wsTool.Range("NameSig").Value
'Logo
Logo = wsTool.Range("Logo").Value & "\" & wsTool.Range("NameLogo").Value
'get relevant columns from sheet "Input"
ColEMail = Split(Cells(1, Application.WorksheetFunction.Match(wsTool.Range("ColNameMail"), wsInput.Range("1:1"), 0)).Address, "$")(1)
'generate E-Mail for each line (range defined in wsTool)
firstRow = wsTool.Range("From").Value
If wsTool.Range("To").Value <> "" And wsTool.Range("To").Value <> " " Then
lastRow = wsTool.Range("To").Value
Else
lastRow = wsInput.Cells(wsInput.Rows.Count, "A").End(xlUp).Row
End If
For Line = firstRow To lastRow
'opens additional E-Mail
Set Mail = outObj.createitem(0)
Set olkPA = Mail.PropertyAccessor
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "Signature.png"
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "Logo.png"
.Subject = Subject
'.
'Body with Foto of Signatures & Logo
.HTMLBody = "<img src='" & Logo & "'>" & "<br><br>" & _
Text & "<br>" & _
"<img src='" & Signature & "'>"
.To = wsInput.Range(ColEMail & Line).Value
End With
Mail.send
Next Line
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
You are setting PR_ATTACH_CONTENT_ID property on the message itself - you must add the attachment (MailItem.Attachments.Add) and then set the PR_ATTACH_CONTENT_ID property on the returned Attachment object to the value matching the cid attribute on the img tag.
Related
I am trying to send email using outlook and vbs.
Parse through excel
take subject, email, name, attachment etc from there. the based on attachment name, i need to insert table from attachment excel into body of email.
set app = CreateObject("Excel.Application")
' get current path
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
strPath = WshShell.CurrentDirectory
Set WshShell = Nothing
'converting csv to xlsx
Set wb = app.Workbooks.Open (strPath+"\"+"rbo1.csv")
WB.SaveAs Replace(WB.FullName, ".csv", ".xlsx"), 51
WB.Close False
wb.close 0
set wb =nothing
Set wb = app.Workbooks.Open (strPath+"\"+"rbo1.xlsx")
set sh = wb.Sheets(1)
row = 2
set name sh.cells("C" & row)
set email = sh.Range("L" & row)
set subject = sh.Range("M" & row)
set attach = sh.Range("N" & row)
Set Cur_date = sh.range("A" & row)
Set Prev_date = sh.range("B" & row)
Set Prev_Bal = sh.range("G" & row)
Set Cur_Bal = sh.range("H" & row)
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, attach, strPath, Cur_date, Prev_date,_
Prev_Bal , Cur_Bal
row = row + 1
name sh.cells("C" & row)
email = sh.Range("L" & row)
subject = sh.Range("M" & row)
attach = sh.Range("N" & row)
Cur_date = sh.range("A" & row)
Prev_date = sh.range("B" & row)
Prev_Bal = sh.range("G" & row)
Cur_Bal = sh.range("H" & row)
End if
Next
wb.close
set wb = nothing
set app = nothing
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, strPath, Cur_date, Prev_date, Prev_Bal , Cur_Bal)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
objXl = app.Workbooks.Open(strPath+"\"+AttachmentPath)
htmlmsg = extracttablehtml(objXl.worksheets(1), objXl.worksheets(1).usedRange)
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
.HTMLBody = "<table> <br> Dear Sir, <br><br> given under details the change balance+"<br> for any query please call under signed<br><br>" + htmlmsg
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
' .Send
End If
End With
objXl.close 0
set objXl = Nothing
Set objOutlook = Nothing
End Sub
Function extracttablehtml(ws, rng)
Dim HtmlContent
Dim i
Dim j
On Error GoTo 0
HtmlContent = "<table>"
For i = 1 To rng.Rows.Count
HtmlContent = HtmlContent & "<tr>"
For j = 1 To rng.Columns.Count
HtmlContent = HtmlContent & "<td>" & ws.Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
extracttablehtml = HtmlContent
End Function
two problems
extracttablehtml is not working as desired please advise whats the problem
now modification i need to do is to choose only rows based on given criteria
thanks in advance
I believe in early 2020 outlook had an update that caused inserted HTML images to not be visible to external parties.
At my old company we had a developer who was able to write something that allowed the image to be visible. I wasn't, and am still not, well versed in coding and have been piecing together stuff, but I can't figure this one out. Not even sure where to start. Any ideas?
If any of the vba below can be cleaned up, please let me know.
Sub Email()
'Create and assign email variables
Dim OutApp As Object
Dim OutMail As Object
'Create and assign JPEF variable
Dim MakeJPG As String
'create and assign workbook variable
Dim wb As Workbook
'create and assign File path variable
Dim Filepath As String
'Create and assign File name variable
Dim Filename As String
'Create and assign File date variable
Dim Filedate As String
'Create and assign Folder Year variable
Dim folderyear As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Filepath = Format(Range("filepath"))
Filename = Format(Range("filename"))
Filedate = Format(Range("trade_date"), "ddmmmyyyy")
folderyear = Format(Range("trade_date"), "yyyy")
'========================================================================
'Copy range you want to paste on new worksheet
Worksheets("Sheet1").Range("A1:Q31").Copy
'Open new workbook
Set wb = Workbooks.Add
Application.DisplayAlerts = False
'paste copied range
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
ActiveSheet.Paste
'Adjust Window Zoom
ActiveWindow.Zoom = 80
'Adjust Gridlines
ActiveWindow.DisplayGridlines = False
'Adjust Header Row Height
Rows("2:5").Select
Selection.RowHeight = 25.5
Rows("6").Select
Selection.RowHeight = 21
'Adjust DA Sales Column Width
Columns("A").ColumnWidth = 6
Columns("B").ColumnWidth = 12
Columns("C").ColumnWidth = 14
Columns("D:E").ColumnWidth = 10
Columns("F").ColumnWidth = 39
Columns("G").ColumnWidth = 10
Columns("H").ColumnWidth = 16
'Adjust RT Sales Column Width
Columns("I").ColumnWidth = 4
Columns("J").ColumnWidth = 12
Columns("K").ColumnWidth = 14
Columns("L:M").ColumnWidth = 10
Columns("N").ColumnWidth = 39
Columns("O").ColumnWidth = 10
Columns("P").ColumnWidth = 16
Columns("Q").ColumnWidth = 6
'Rename worksheet
ActiveSheet.Name = "Sheet1"
'Save new worksheet with pasted range
wb.SaveAs Filename:=Filepath & Filename & " " & Filedate & ".xlsx"
Application.DisplayAlerts = True
'Close active workbook
ActiveWorkbook.Close True
'========================================================================
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'========================================================================
'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("Sheet1", "A1:Q31")
If MakeJPG = "" Then
MsgBox "Something went wrong, can't create email"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
'========================================================================
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.Display
End With
Signature = OutMail.HTMLBody
'========================================================================
'Define & Assign To email list using a named range
Set emailRng = Worksheets("Sheet1").Range("to_email")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
Set emailRng2 = Worksheets("Sheet1").Range("cc_email")
For Each cl2 In emailRng2
sCc = sCc & ";" & cl2.Value
Next
sCc = Mid(sCc, 2)
'========================================================================
With OutMail
.To = sTo '"Manually enter email address here"
.cc = sCc '"Manually enter email address here"
.BCC = ""
.Subject = Filename & " " & Range("trade_date")
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=1150 height=600></html>" & "<br><br>" & Signature & "<br><br>"
.Attachments.Add Filepath & Filename & " " & Filedate & ".xlsx"
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'========================================================================
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Create an HTML table from the range rather than an image attachment.
Option Explicit
Sub Email()
Const RNG_EMAIL = "A1:Q31"
Dim wb As Workbook, ws As Worksheet
Dim filepath As String, filename As String
Dim filedate As String, FolderYear As String
Dim rng As Range, msg As String
Set ws = ThisWorkbook.Sheets("Sheet1")
filepath = Range("filepath")
filename = Range("filename")
filedate = Format(Range("trade_date"), "ddmmmyyyy")
FolderYear = Format(Range("trade_date"), "yyyy")
'Copy range you want to paste on new worksheet
Set rng = ws.Range(RNG_EMAIL)
rng.Copy
Set wb = Workbooks.Add(xlWBATWorksheet) ' one sheet
wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False
FormatSheet wb.Sheets(1)
With ActiveWindow
.Zoom = 80
.DisplayGridlines = False
End With
'Save new worksheet with pasted range and close
Application.DisplayAlerts = False
wb.SaveAs filename:=filepath & filename & " " & filedate & ".xlsx"
Application.DisplayAlerts = True
wb.Close False
' prepare and send email
msg = SendEmail(ws, rng)
MsgBox msg, vbInformation
End Sub
Function SendEmail(ws As Worksheet, rng As Range) As String
Const CSS = "body{font:12px Verdana};p{font:14px Verdana Bold};"
Dim OutApp As Object, OutMail As Object, cell As Range
Dim sTo As String, sCc As String
Dim signature As String, strbody As String
' some message text
strbody = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, " & _
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua"
'Define & Assign To email list using a named range
For Each cell In ws.Range("to_email")
sTo = sTo & ";" & cell.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
For Each cell In ws.Range("cc_email")
sCc = sCc & ";" & cell.Value
Next
sCc = Mid(sCc, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.To = sTo
.cc = sCc
.BCC = ""
.Subject = Range("filename") & " " & Range("trade_date")
signature = .HTMLBody
.HTMLBody = "<html><style>" & CSS & "</style><p>" & strbody & "</p>" & _
RngToHtml(rng) & "<br><br>" & signature & "</html>"
.Display 'or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
SendEmail = "Email sent to " & sTo
End Function
Function RngToHtml(rng As Range)
Dim t As String, r As Long, c As Long
For r = 1 To rng.Rows.Count
t = t & "<tr>"
For c = 1 To rng.Columns.Count
t = t & "<td>" & rng.Cells(r, c) & "</td>"
Next
t = t & "</tr>" & vbCrLf
Next
RngToHtml = "<table width=""1150"">" & t & "</table>"
End Function
Sub FormatSheet(ws As Worksheet)
Dim colWidth, c As Integer
'DA and RT Sales Column Width A-Q
colWidth = Array(6, 12, 14, 10, 10, 39, 10, 16, _
4, 12, 14, 10, 10, 39, 10, 16, 6)
With ws
.Rows("2:5").RowHeight = 25.5
.Rows("6").RowHeight = 21
For c = 0 To UBound(colWidth)
.Columns(c + 1).ColumnWidth = colWidth(c)
Next
End With
End Sub
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 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
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