I am having issues with inserting image (chart) into an HTMLbody. I export the chart to another folder and then call the image path.
msg = "<html>123,<br/> 123 <b>" & countries & ":</b><br/>" & RangetoHTML(tablex) & s & "<img src=""cid:" & fileName & "><html\>"
However, after I insert the image with the above message body it shows:
And after the adjustments by correctly specifying which image, I get:
To specify the exact image I use:
Set myChart = wbe.Sheets("Sheet1").ChartObjects("Chart 11").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.jpg"
myPath = "C:\qwe\"
fileName = myPath & myPicture
myChart.Export fileName
Whole code:
Sub transactional_emails()
'Create email and save it as draft
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim source As String
Dim oAccount As String
Dim msg As String
Dim tablex As Range
Dim wbe As Workbook
Dim las As Long
Dim countries As String
Dim myChart As Chart
countries = "LOL"
Set wbe = Workbooks(ThisWorkbook.Name)
las = wbe.Sheets("Sheet1").Cells(wbe.Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
Set tablex = wbe.Sheets("Sheet1").Range("A1:G" & las)
With tablex.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
Set myChart = wbe.Sheets("Sheet1").ChartObjects("Chart 11").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.jpg"
myPath = "C:\qwe\"
fileName = myPath & myPicture
myChart.Export fileName
'Create the Outlook application and the empty email.
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Dim s As String
s = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(s, vbDirectory) <> vbNullString Then s = s & Dir$(s & "*.htm") Else s = ""
s = CreateObject("Scripting.FileSystemObject").GetFile(s).OpenAsTextStream(1, -2).ReadAll
msg = "<html>123,<br/> 123 <b>" & countries & ":</b><br/>" & RangetoHTML(tablex) & s & "<img src=""cid:" & myPicture & """></html>"
With olMailItm
SDest = "gal.bordelius_ext#novartis.com"
'oAccount = "customer.service_GOC#novartis.com"
.To = SDest
.CC = "gal.bordelius_ext#novartis.com"
.Subject = countries & " 123 " & Date
.Attachments.Add fileName, 1, 0
.htmlbody = msg
.Save
End With
'Clean up the Outlook application.
Set olMailItm = Nothing
Set olApp = Nothing
End sub
The source code is valid:
You attach an image to the mail item in Outlook:
.Attachments.Add fileName, 1, 0
Then you can refer to the attached image from the message body in the following way:
"<img src=""cid:" & myPicture & """>
Sometimes you also need to set the PR_ATTACH_CONTENT_ID property (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F) on the attachment using Attachment.PropertyAccessor.
You may also consider adding some parameters like height or width. Note, the image name can't contains spaces.
When you open an email message that contains images in Microsoft Office Outlook, the image areas can be blocked. Read more about that in the Pictures cannot be displayed and are shown as red X in Outlook article.
Related
When I go to sent emails with the code below it sends a previous version of the email. It doesn't reset.
Private Sub CommandButton16_Click()
Dim EmailApp As Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailApp = New Outlook.Application
Dim EmailAddress As String
Dim EmpName As String
Dim ProvName As String
Dim PayMonth As String
Dim Filename As String
Dim Filepath As String
Dim FileExists As String
Dim Subject As String
Dim Source As String
Dim AltEmail As String
Dim ExtraMsg As String
Dim i As Long
'Loop through and get email address and names
i = 2
PayMonth = TextBox6.Value
AltEmail = TextBox7.Value
ExtraMsg = TextBox8.Value
Do While Worksheets("Provider Template").Cells(i, 1).Value <> ""
ProvName = Worksheets("Provider Template").Cells(i, 1).Value
EmpName = Worksheets("Provider Template").Cells(i, 11).Value
If AltEmail = "" Then EmailAddress = Worksheets("Provider Template").Cells(i, 20).Value Else EmailAddress = AltEmail
Filename = ProvName & " " & PayMonth
Filepath = ThisWorkbook.Path & "\Remittance PDFs\"
Source = Filepath & Filename & ".pdf"
Subject = "Monthly Remittance Advice for" & " " & ProvName & " - " & PayMonth
FileExists = Dir(Source)
If FileExists = "" Then GoTo Lastline Else GoTo SendEmail
SendEmail:
Set EmailItem = EmailApp.CreateItem(olMailItem)
With EmailItem
EmailItem.To = EmailAddress
EmailItem.CC = "******************"
EmailItem.Subject = Subject
EmailItem.HTMLBody = "<html><body><p>Here is the tax invoice and calculation sheet for " & ProvName & ".</p><p>" & ExtraMsg & "</p><p>Kind regards, ******</p><p>****** ******</p><p>Practice Manager</p></body></html>"
EmailItem.Attachments.Add Source
EmailItem.Send
End With
GoTo Lastline
Lastline:
i = i + 1
Loop
End Sub
I thought it was a problem in the code then I ran it on a different machine and fresh emails were sent. I uploaded the updated version to a work machine and the old emails are going again, like there is a cache of this stuff somewhere.
You can try to check your "Sent" box in outlook next time. It's possible that outlook did'nt sent them (offline or other reason),thety are still there as a draft. That could be the reason that they where sent later.
And adjust:
With EmailItem .To = EmailAddress
And you can leave this out;
GoTo Lastline Lastline:
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
I want to add signatures with images. Images here refer to company logo and social networking icons.
This code is written in Excel VBA and the goal is to copy paste the range as a picture in Outlook email.
Dim Rng As Range
Dim outlookApp As Object
Dim outMail As Object
Dim wordDoc As Word.Document
Dim LastRow As Long
Dim CcAddress As String
Dim ToAddress As String
Dim i As Long
Dim EndRow As String
Dim Signature As String
'// Added Microsoft word reference
Sub Excel_Image_Paste_Testing()
On Error GoTo Err_Desc
'\\ Define Endrow
EndRow = Range("A65000").End(xlUp).Row
'\\ Range for copy paste as image
Set Rng = Range("A22:G" & EndRow)
Rng.Copy
'\\ Open a new mail item
Set outlookApp = CreateObject("Outlook.Application")
Set outMail = outlookApp.CreateItem(0)
'\\ Display message to capture signature
outMail.Display
'\\ This doesnt store images because its defined as string
'Problem lies here
Signature = outMail.htmlBody
'\\ Get its Word editor
Set wordDoc = outMail.GetInspector.WordEditor
outMail.Display
'\\ To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'\\ TO and CC Address
CcAddress = "xyz#gmail.com"
ToAddress = "abc#gmail.com"
'\\ Format email
With outMail
.htmlBody = .htmlBody & Signature
.Display
.To = ToAddress
.CC = CcAddress
.BCC = ""
.Subject = "Email Subject here"
.readreceiptrequested = True
End With
'\\ Reset selections
Application.CutCopyMode = False
Range("B1").Select
Exit Sub
Err_Desc:
MsgBox Err.Description
End Sub
This file is to be distributed to many people. I wouldn’t know the default .htm signature name.
(“AppData\Roaming\Microsoft\Signatures”)
People may also have many signatures but my goal is to capture their default signature.
Error signature picture after running the code
My signature should be as shown below.
In this code we will let the user select the .Htm file from AppData\Roaming\Microsoft\Signatures
The problem is that we cannot directly use the html body of this file because the images are stored in a different folder named as filename_files as shown below.
Also the paths mentioned in the htmlbody are incomplete. See the below images
Here is a quick function that I wrote which will fix the paths in the html body
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "_files"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
Here is the complete procedure. I have commented the code. Let me know if you still have any issues.
Sub Sample()
Dim oOutApp As Object, oOutMail As Object
Dim strbody As String, FixedHtmlBody As String
Dim Ret
'~~> Ask user to select the htm file
Ret = Application.GetOpenFilename("Html Files (*.htm), *.htm")
If Ret = False Then Exit Sub
'~~> Use the function to fix image paths in the htm file
FixedHtmlBody = FixHtmlBody(Ret)
Set oOutApp = CreateObject("Outlook.Application")
Set oOutMail = oOutApp.CreateItem(0)
strbody = "<H3><B>Dear Blah Blah</B></H3>" & _
"More Blah Blah<br>" & _
"<br><br><B>Thank you</B>" & FixedHtmlBody
On Error Resume Next
With oOutMail
.To = "Email#email.com" '<~~ Change as applicable
.CC = ""
.BCC = ""
.Subject = "Example on how to insert image in signature"
.HTMLBody = .HTMLBody & "<br>" & strbody
.Display
End With
On Error GoTo 0
Set oOutMail = Nothing
Set oOutApp = Nothing
End Sub
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "_files"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> To cater for spaces in signature file name
FullPath = Replace(FullPath, " ", "%20")
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
'~~> Gets File Name from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End Function
In Action
I'm using a script that opens an email and downloads its attachment. Right now I can either choose to download the most recent attachment on the most recent email:
Sub CTEmailAttDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For Each oOlItm In oOlResults
If oOlItm.Attachments.Count > 0 Then
For Each oOlAtch In oOlItm.Attachments
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next oOlItm
End Sub
'----------------------------------------------------------------------
' GetExt
'
' Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String
Dim mFSO As Object
Set mFSO = CreateObject("Scripting.FileSystemObject")
GetExt = mFSO.GetExtensionName(FileName)
End Function
By using '[Subject] =' I can download it by subject.
My question is, how can I put those two filters together so I can filter by Subject and ReceivedTime?
I tried binding them together with ,, &, + and so far I haven't been successful.
#SQL=(Subject LIKE '%blah%') AND (ReceivedTime > '01/02/2015')
It is a struggle to get the syntax for even one restrict. As indicated in the comment by Scott Holtzman, if you know each filter separately, you can filter twice.
Option Explicit
Sub CTEmailAttDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim oOlSubjectResults As Object
Dim strFilter As String
Dim i As Long
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & format(Date - 1, "DDDDD HH:NN") & "'")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%test%'"
Set oOlSubjectResults = oOlResults.Restrict(strFilter)
If oOlSubjectResults.count = 0 Then
Debug.Print "No emails found with applicable subject"
Else
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For i = 1 To oOlSubjectResults.count
Set oOlItm = oOlSubjectResults(i)
If oOlItm.Attachments.count > 0 Then
Debug.Print oOlItm.Subject
For Each oOlAtch In oOlItm.Attachments
Debug.Print oOlAtch.DisplayName
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next i
End If
ExitRoutine:
Set oOlAp = Nothing
Set oOlns = Nothing
Set oOlInb = Nothing
Set oOlResults = Nothing
Set oOlSubjectResults = Nothing
End Sub