My default email signature is overwritten by an embedded image. The signature shows up at first and then the picture takes its place.
I want this code to work for other people. How can I add the default email signature?
Sub Send_Email()
Dim pdfPath As String, pdfName As String
'PDF name same as the workbook.name
pdfName = "VW Fuel Marks_" & Format(Date, "m.d.yyyy")
'PDF save path same as workbook path, where the workbook is saved
pdfPath = ThisWorkbook.Path & "\" & pdfName & ".pdf"
'Selecting sheets (if any of the sheets hidden it will run to an error)
ThisWorkbook.Sheets(Array("Daily Dashboard-Page1", "Daily Dashboard-Page2", "Daily Dashboard-Page3", "Daily Dashboard-Page4")).Select
'Create pdf and open it (if a pdf with a same name is already opened it will run to an error)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.Worksheets(19).Range("A1:T42").CopyPicture xlScreen, xlPicture
Dim OApp As Object, OMail As Object, Signature As String
Dim cell As Range, S As String, WMBody As String, lFile As Long
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.Display
End With
Signature = OMail.HTMLBody
With OMail
.To = Range("AG3").Value
.CC = Range("AG4").Value
.Subject = Range("A1").Value
.HTMLBody = Replace(Signature, "<div class=WordSection1><p class=MsoNormal><o:p>", "<div class=WordSection1><p class=MsoNormal><o:p>" & sBody)
.Attachments.Add pdfPath
OMail.Display
End With
'.Attachments.Add
Set ins = OMail.GetInspector
'need add reference to Microsoft Word Object Library
Dim doc As Word.Document
Set doc = ins.WordEditor
doc.Select
doc.Application.Selection.Paste
OMail.Display
Set OMail = Nothing
Set OApp = Nothing
End Sub
You need to insert the content right after the opening <body> tag. In that case the rest content will be preserved as is.
With OMail
.Display
End With
Signature = OMail.HTMLBody
With OMail
.To = Range("AG3").Value
.CC = Range("AG4").Value
.Subject = Range("A1").Value
' here you need to find the <body> tag and insert the new content right after it
.HTMLBody = ...
.Attachments.Add pdfPath
OMail.Display
End With
You can use VBA string functions to find the <body> tag and paste the content right after it.
You select the body then paste over it.
Set doc = ins.WordEditor
doc.Select
doc.Application.Selection.Paste
Instead paste at the top, in a smaller size.
Set doc = ins.WordEditor
doc.Range(0, 0).Paste
This pastes at the top with size matching your code.
Set doc = ins.WordEditor
Dim wdRange As Word.Range
Set wdRange = doc.Range(0, 0)
wdRange.Select
doc.Application.Selection.Paste
Related
I want to attach a chart in the email when the user clicks on a button.
The code isn't adding the chart.
The naming is correct and I am not receiving any errors (except ones I've implemented to help test).
If ChartNameLine = "" Then
GoTo ErrorMsgs
Else
Dim xOutApp As Object
Dim xOutMail As Object
Dim xChartName As String
Dim xPath As String
Dim xChart As ChartObject
Dim xChartPath As String
On Error Resume Next
xChartName = Application.InputBox("Please Enter the Chart name: ", "KuTools for Excel", , , , , , 2)
'xChartName = ChartNameLine
Set xChart = Worksheets(.HTMLBody).ChartObjects(xChartName)
xChart.Chart.ChartArea.Copy
errorCode = 101
'If xChart Is Nothing Then GoTo ErrorMsgs
xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xChartPath = ThisWorkbook.path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".bmp"
xPath = "<p align='Left'><img src= " / "cid:" & Mid(xChartPath, InStrRev(xChartPath, "\") + 1) & """ width = 800 height = 500> <br> <br>"
xChart.Chart.Export xChartPath
With xOutMail
.To = ToLine
.Subject = SubjectLine
.Attachments.Add xChartPath
.HTMLBody = xPath
.Display
End With
Kill xChartPath
'Set xOutMail = Nothing
'Set xOutApp = Nothing
End If
Using code from "Extend Office"
Create a chart in a new workbook with a sheet named "test". The chart should be named "Chart 1".
With no other code in the new workbook.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub AddWorksheetTestChartToMail()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xChartName As String
Dim xPath As String
Dim xChart As ChartObject
Dim xChartPath As String
xChartName = "Chart 1"
' "test", not .HTMLBody
Set xChart = Worksheets("test").ChartObjects(xChartName)
xChart.Chart.ChartArea.Copy
' Set was missing
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xChartPath = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".bmp"
Debug.Print xChartPath
' suggested fix in comment on the question post - src=""cid:"
xPath = "<p align='Left'><img src=""cid:" & Mid(xChartPath, InStrRev(xChartPath, "\") + 1) & """ width=700 height=500 > <br> <br>"
xChart.Chart.Export xChartPath
With xOutMail
.To = "ToLine"
.Subject = "SubjectLine"
.Attachments.Add xChartPath
.HTMLBody = xPath
.Display
End With
Kill xChartPath
End Sub
First of all, the HTMLBody property returns or sets a string representing the HTML body of the specified item. If you need to add an image generated in Excel you most probably need to insert it at some point in the message, not substitute the whole message by setting it to the paragraph HTML tag. So, find a suitable place in the HTML document and insert the generated HTML piece there instead of replacing the whole message body.
Second, make sure a correct image is generated and saved to the disk. And there were no problems with image generation process from the Excel side.
Third, you may need to set the PR_ATTACH_CONTENT_ID property on the attached image so Outlook could easily recognize the embedded image.
I have used both the .body and .HTMLbody. With both approaches I managed to get only 90% of what I want. I prefer using .HTMLBody as it allows the signature to be populated.
Below is the coding from various online tutorials/vids.
Sub CopyRangeToOutlook_Client 1()
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
Dim signature As String
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim ExcRng As Range
On Error Resume Next
Set oLookApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Err.Clear
Set oLookApp = New Outlook.Application
End If
Set oLookItm = oLookApp.CreateItem(olMailItem)
signature = oLookItm.Body
Set ExcRng = Sheet3.Range("A1:E26")
strbody = "<BODY style = font-size:14pt;Color:RGB(96,97,96)>" & _
"Dear Client,<p> I trust you are well.<p>" & _
"Please see below ............. weekly reference rates.<p>" & _
"Kind Regards"
With oLookItm
.Display
.To = "xxxxxxxxxxxxx.com"
.CC = "xxxxxxxxxxxxx.com"
.Subject = "xxxxxxxxxxxxxxxx // xxxxxxxxxxxxxxxx (Pty) Ltd - Weekly Reference Rate" & " - " &
Format(Date, "(dd-mm-yyyy)")
.HTMLBody = strbody & _
.HTMLBody
Set oLookIns = .GetInspector
Set oWrdDoc = oLookIns.WordEditor
Set oWrdRng = oWrdDoc.Application.activeDocument.Content
oWrdRng.collapse Direction:=wdCollapseEnd
Set oWrdRng = oWdEditors.Paragraphs.Add
ExcRng.Copy
oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
End With
End Sub
The email is created using the .HTMLBody format with the defined context in the strbod0y with the desired signature at the bottom.
The Excel range extracted as the image appears after the signature section.
I would like it between the text as defined in the strbody or if it is possible to mark the space between the text and paste the image at the preserved "location".
Here is a way you could do it.
Sub Demo()
Dim Body As String
' Define your email body, use placeholder
' where you want image to go, e.g. [IMAGE]
Body = "<BODY style = font-size:14pt;Color:RGB(96,97,96)>" & _
"Dear Client,<p> I trust you are well.</p>" & _
"<p>Please see below ............. weekly reference rates.</p>" & _
"[IMAGE]" & _
"<p>Kind Regards</p>"
With CreateObject("Outlook.Application").CreateItem(0)
.Display
.To = "xxxxxxxxxxxxx.com"
.CC = "xxxxxxxxxxxxx.com"
.Subject = "xxxxxxxxxxxxxxxx // xxxxxxxxxxxxxxxx (Pty) Ltd - Weekly Reference Rate" & " - " & _
Format(Date, "(dd-mm-yyyy)")
.HTMLBody = Body & .HTMLBody
With .GetInspector.WordEditor.Content
' If the placeholder exists...
If .Find.Execute("[IMAGE]") Then
' Copy image from Excel
Sheets("Sheet3").Shapes("Picture 1").CopyPicture
' Paste over placeholder
.Paste
End If
End With
End With
End Sub
I am using a below code that is pasting a table from excel to the outlook file. However, right now the table is pasted on the very bottom of the email - after the signature.
What I would like to achieve is to have the table inserted after a word "region." and before "Regards" - so before signature.
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim mySubject As String
Dim myPath As String
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Prompt for Email Subject
Set outlApp = CreateObject("Outlook.Application")
weeknumber = "Week " & WorksheetFunction.WeekNum(Now, vbMonday)
'mySubject = InputBox("Subject for Email")
For i = 2 To 3
region = Sheets("Sheet1").Cells(i, 5).Value
mySubject = "Overdue Milestones | " & weeknumber & " | " & region
'Copy every sheet from the workbook with this macro
Set Sourcewb = ActiveWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = "C:\Users\mxr0520\Desktop\Ignite Reports\Milestones\" & weeknumber
If i < 3 Then
MkDir FolderName
Else
End If
'Copy every visible sheet to a new workbook
Set sh = Sheets(region)
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy
'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
End With
'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
'Save the new workbook, email it, and close it
'Set otlNewMail = outlApp.CreateItem(myMailItem)
Set OutLookApp = CreateObject("Outlook.application")
Set OutlookMailitem = OutLookApp.CreateItem(0)
With OutlookMailitem
.display
End With
Signature = OutlookMailitem.htmlbody
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
End With
myPath = ActiveWorkbook.path & "\" & ActiveWorkbook.Name
With Destwb
.Close False
End With
With OutlookMailitem
.Subject = mySubject
.To = Sheets("Sheet1").Cells(i, 6)
.CC = Sheets("Sheet1").Cells(i, 7)
.htmlbody = "Dear All," & "<br>" _
& "<br>" _
& "Attached please find the list of milestones that are <b>overdue</b> and <b>due in 14 days</b> for " & region & "." & "<br>" & "<br>" & "Regards," & "<br>" _
& "Marek" _
& Signature
.Attachments.Add myPath
Worksheets("Summary").Range("A1:E14").Copy
Set vInspector = OutlookMailitem.GetInspector
Set weditor = vInspector.WordEditor
wEditor.Application.Selection.Start = Len(.body)
wEditor.Application.Selection.End = wEditor.Application.Selection.Start
wEditor.Application.Selection.Paste
.display
End With
Set OutlookMailitem = Nothing
End If
thank you for help in advance!
Probably easiest to do this by creating an .oft (Outlook Email Template) with the message body and a placeholder for "region" and the table. Create the template without a signature, it will be added automatically per your Outlook user settings, later. I create a template like this, and save as .oft:
Then simply create the new mailitem with Set OutlookMailitem = OutlookApp.CreateItemFromTemplate({path to your template.oft}), replace the "region" placeholder, and copy/paste the table to the table placeholder's location.
Option Explicit
Sub foo()
Dim objOutlook As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim wdDoc As Word.Document
Dim tblRange As Word.Range
Dim region As String
' define your Region, probably this is done in a loop...
region = "Region 1"
Set objOutlook = CreateObject("Outlook.Application")
' Create email from the template file // UPDATE WITH YOUR TEMPLATE PATH
Set objMsg = objOutlook.CreateItemFromTemplate("C:\path\to\your\template.oft")
objMsg.Display
Set wdDoc = objOutlook.ActiveInspector.WordEditor
' replace placeholder with region:
wdDoc.Range.Find.Execute "{{REGION PLACEHOLDER}}", ReplaceWith:=region
' in my template, paragraph 5 is the table placeholder, modify as needed:
Set tblRange = wdDoc.Range.Paragraphs(5).Range
tblRange.Text = "" ' remove the placeholder text
' copy the Excel table // modify to refer to your correct table/range
Sheet1.ListObjects(1).Range.Copy
' paste the table into the email
tblRange.PasteExcelTable False, False, False
End Sub
As you can see, the final email contains my default signature (which was not part of the template.oft file).
You can use the following properties to customize the message body:
Body - a string representing the clear-text body of the Outlook item.
HTMLBody - a string representing the HTML body of the specified item.
The Word Editor. The WordEditor property of the Inspector class returns an instance of the Word Document which represents the message body. You can find all these ways described in the Chapter 17: Working with Item Bodies in MSDN.
The Outlook object model doesn't provide any property or method for detecting signatures. You parse the message body and try to find such places.
However, when you create a signature in Outlook, three files (HTM, TXT and RTF) are created in the following folders:
Vista and Windows 7/8/10:
C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures
Windows XP:
C:\Documents and Settings\<UserName>\Application Data\Microsoft\Signatures
Application Data and AppData are hidden folders, change the view in the Windows explorer so it shows hidden files and folders if you want to see the files.
So, you read the content of these files and try to find the corresponding content in the message body. Note, users may type a custom signature in the end of emails.
My aim is to paste a range as an image into an Outlook email. I turned on the references in the VBA editor for MS Excel, Word and Outlook 15.0 as my latest version on my network.
I've spent hours looking through previously answered similar questions.
I cannot save the image as a temporary file/use html to reference the attachment as a solution due to other users not having access to specific drives where it would be temporarily saved if they ran the code on their own machines.
If I remove the email body section the image pastes fine however if I have both pieces of code in together, the email body writes over the image. I do however need the image to be pasted within the email body text.
Sub CreateEmail()
Dim OlApp As Object
Dim OlMail As Object
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim PictureRange As Range
Dim OApp As Object, OMail As Object, signature As String
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.createitem(olmailitem)
ExtractName = ActiveWorkbook.Sheets("macros").Range("C11").Value
ToRecipient = ActiveWorkbook.Sheets("macros").Range("K11")
OlMail.Recipients.Add ToRecipient
CC_Check = ActiveWorkbook.Sheets("macros").Range("k10")
If CC_Check = "" Then GoTo Skip_CC
CcRecipient = ActiveWorkbook.Sheets("macros").Range("K10")
OlMail.Recipients.Add CcRecipient
OlMail.Subject = ExtractName
signature = OlMailbody
With OlMail
Set PictureRange = ActiveWorkbook.Sheets("DCTVV").Range("A2:D13")
PictureRange.Copy
OlMail.Display
'This section pastes the image
Dim wordDoc As Word.Document
Set wordDoc = OlMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
'This section is the email body it needs inserting into
OlMail.body = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
"IMAGE NEEDS TO BE PASTED HERE" _
& vbNewLine & vbNewLine & "More text here" _
& vbNewLine & vbNewLine & "Kind regards,"
.signature
End With
Set OMail = Nothing
Set OApp = Nothing
OlMail.Attachments.Add ("filepath &attachment1")
OlMail.Attachments.Add ("filepath &attachment2")
'OlMail.Attachments.Add ("filepath &attachment3")
OlMail.Display
End Sub
From what I understand the picture pastes fine to email's body, right?
In this case you might just need to add .HTMLBody like so:
olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
.HTMLBody & _
vbNewLine & vbNewLine & "More text here" & _
vbNewLine & vbNewLine & "Kind regards,"
This is an example of my code that we use on my job te send emails:
Call CrearImagen
ReDim myFileList(0 To Contador - 1)
For i = 0 To Contador - 1
myFileList(i) = wb.Path & "\" & Servicio & i & ".jpg"
ImagenesBody = ImagenesBody & "<img src='cid:" & Servicio & i & ".jpg'>"
Next i
With OutMail
.SentOnBehalfOfName = "ifyouwanttosendonbehalf"
.Display
.To = Para
.CC = CC
.BCC = ""
.Subject = Asunto
For i = 0 To UBound(myFileList)
.Attachments.Add myFileList(i)
Next i
Dim Espacios As String
Espacios = "<br>"
For i = 0 To x
Espacios = Espacios + "<br>"
Next
.HTMLBody = Saludo & "<br><br>" & strbody & "<br><br><br>" _
& ImagenesBody _ 'here are the images
& Espacios _ 'more text
& .HTMLBody
.Display
End With
On Error GoTo 0
'Reformateamos el tamaño de las imagénes y su posición relativa al texto
Dim oL As Outlook.Application
Set oL = GetObject("", "Outlook.application")
Const wdInlineShapePicture = 3
Dim olkMsg As Outlook.MailItem, wrdDoc As Object, wrdShp As Object
Set olkMsg = oL.Application.ActiveInspector.CurrentItem
Set wrdDoc = olkMsg.GetInspector.WordEditor
For Each wrdShp In wrdDoc.InlineShapes
If wrdShp.Type = wdInlineShapePicture Then
wrdShp.ScaleHeight = 100
wrdShp.ScaleWidth = 100
End If
If wrdShp.AlternativeText Like "cid:Imagen*.jpg" Then wrdShp.ConvertToShape
Next
'Limpiamos los objetos
For i = 0 To UBound(myFileList)
Kill myFileList(i)
Next i
Set olkMsg = Nothing
Set wrdDoc = Nothing
Set wrdShp = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Now if you can already create the images, just save them on the workbook path and you can attach them like this. When attaching images I suggest you that the names of the files don't contain spaces, found out this the hard way until figured it out, html won't like them with spaces.
If your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
As the VBA code below use 'Late Binding', it's also compatible with all previous and current versions of MS Office viz. Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'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
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
I'd like to build\edit the mail signiture in Excel:
1st cell : |Regards, |
2nd cell (Name) : |Asaf Gilad |
3rd Cell (Title): |PMO |
4th cell (Mail) : |Asaf#mail.com |
So that when I click send, the body of the message will look like:
Dear sir
................................
....... Message Content ........
................................
................................
Regards,
Asaf Gilad
PMO
Asaf#mail.com
The signiture contains pictures as well.
I managed to save the range as picture and send that picture as attachment, but the picture turned out to be empty in the body, dispite the fact that it was sent correctly as attachment.
Here is the code I use:
Public Sub ExportEmail(recipentName As String)
On Error GoTo err:
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String
Dim FNAME As String
Dim oRange As Range
Dim oChart As Chart
Dim oImg As Picture
strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""
strEmailTo = "a#a.com"
strEmailCC = "b#b.com
If strEmailTo "" Then
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = strEmailTo
olMail.CC = strEmailCC
olMail.BCC = strEmailBCC
olMail.Subject = " My Subject"
Set oRange = Sheets(1).Range("A1:Z100")
Set oChart = Charts.Add
oRange.CopyPicture xlScreen, xlPicture
oChart.Paste
FNAME = Environ$("temp") & "\testPic.gif"
oChart.Export Filename:=FNAME, FilterName:="GIF"
olMail.Attachments.Add FNAME
olMail.HTMLBody = "" & _
""
olMail.Attachments.Add FNAME
olMail.Send
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Kill FNAME
Set olApp = Nothing
Set olNs = Nothing
Set oRange = Nothing
Set oChart = Nothing
Set oImg = Nothing
Exit Sub
err:
MsgBox err.Description
End Sub
This is a good question, Asaf. When I have built automated e-mail solutions, I've found it difficult to get the signature line in. It's possible, but not easy. Maybe it's updated in 2010, but I haven't checked yet.
What I do is place the entire body into a text file on a drive, complete with any html tags that I want for formatting. This gives me great flexibility in both making nicely formatted e-mails where I can assign variables as well.
I then access those files through the Microsoft Scripting Runtime library.
See below code snippets:
Option Explicit
Const strEmailBoiler As String = "\\server\path\folder\subfolder\email_text\"
Sub PrepMessage()
Dim strBody As String, strMon As String
strMon = range("Mon").Value
strFY = range("FY").Value
strBody = FileToString(strEmailBoiler, "reports_email_body.txt")
strBody = Replace(strBody, "[MONTH]", strMon)
strBody = Replace(strBody, "[YEAR]", Right(strFY, 2))
strBody = Replace(strBody, "[FILE PATH]", strFileName)
SendMail "firstname.lastname#xyz.com", "Subject Goes Here " & strMon & " YTD", strBody
End Sub
Function FileToString(ByVal strPath As String, ByVal strFile As String) As String
'requires reference to Microsoft Scripting Runtime Object Library (or late binding)
Dim ts As TextStream
Set fso = New FileSystemObject
Set ts = fso.OpenTextFile(strPath & strFile, ForReading, False, TristateUseDefault)
FileToString = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End Function
Sub SendMail(strTo As String, strSubject As String, strHTMLBody As String, Optional strAttach As String, Optional strCC As String)
'requires reference to Microsoft Outlook X.X Object Library (or late binding)
Dim olApp As Outlook.Application
Dim olMI As Outlook.MailItem
Set olApp = CreateObject("Outlook.Application")
Set olMI = olApp.CreateItem(olMailItem)
With olMI
.To = strTo
.Subject = strSubject
.HTMLBody = strHTMLBody
If strAttach <> vbNullString Then .Attachments.Add strAttach
.Display 'using this because of security access to Outlook
'.Send
End With
End Sub
Then my reports_email_body.txt file will look like this:
<p>Hello Person,</p>
<p>The Reports file for [MONTH] FY[YEAR] has been saved in the following location:</p>
<p>[FILE PATH]</p>
<p>Best,</p>
<br>
Scott Holtzman
<br>My Address
<br>my title
<br>whatever else...
In Excel 2010 (and possibly 2007) you can add .HTMLBody to the end of your body string. For instance, use something like this:
.HTMLBody = "<br>" & strbody & .HTMLBody
' <br> is an HTML tag to turn the text into HTML
' strbody is your text from cell C9 on the mail tab
' .HTMLBody inserts your email signature
This will at least solve your signature line problem.
I am looking for a solution for the same problem: Inserting a range as a picture.