Attaching PDF file to Outlook email - excel

I would like to add a .pdf file in my Outlook email, which is sent via VBA Excel.
My full Excel code looks pretty much like this:
Sub Confirmationemail()
MsgBox ("The confirmation email will be sent now")
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Dim fs As Worksheet, bs As Worksheet
Dim Filename As String, Name As String, Name2 As String, Name3 As String, Reason As String
Dim Cost As String, PathFileName As String
Dim linecount2 As Long
ChDir ThisWorkbook.Path & "\"
Set fs = Sheets("Frontsheet")
Set bs = Sheets("BoM")
linecount2 = 1
Name = fs.Range("D10")
Name2 = fs.Range("D18")
Name3 = fs.Range("D38")
If fs.Range("D38").Value = 3 Then
Reason = fs.Range("K8")
ElseIf fs.Range("D38").Value = 4 Then
Reason = fs.Range("P4")
Else
Reason = fs.Range("K4")
End If
Filename = Name & "_" & Name2
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "The job is ready. See the PDF version in the attachment"
.To = "xxx#xxx.co.uk; yyy#yyy-is.co.uk "
PathFileName = ThisWorkbook.Path & "\" & Filename & ".pdf"
.CC = "zzz#z-is.co.uk; www#wx-c.co.uk;"
.BCC = "yxks#ug.co.uk"
.Subject = Filename & "- Audit"
'.Attachments.Add PDFFile
myattachments.Add PathFileName
'.Attachments.Add Application.ActiveWorkbook.FullName
'.Send
End With
End Sub
The best hint I found:
How to attach exported pdf file to Outlook mail using Excel VBA? but it refers to attaching the already exported PDF document. Incorporating some pieces of code was unsuccessful.
Some solution here:
Attach PDF and send email via Outlook but it refers to the specified cells only.
Other hints I found:
Excel VBA attaching print area as PDF.
Attach both pdf and excel files to an email on single click in VBA.
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_winother-mso_2010/attaching-a-pdf-file-in-vba-generated-email-in/527de6b4-66e6-4aa5-85b8-267a59ea6a7f

It’s not myattachments.Add PathFileName it should be .Attachments.Add PathFileName
See Attachments.Add method (Outlook)

Related

VBA FilePicker no longer opening from ThisWork.Path

I have a workbook (located on our network) with a macro enabled so I can email exported PDF worksheets via Outlook every Friday. The exported worksheet PDF gets saved to the same location as the Workbook. Outlook then opens the FilePicker and lets me select the file that I want to attach to the email. For some reason the Filepicker is now not opening to ThisWork.path anymore; it opens to my default MyDocuments located on my native computer. The exported file still saves in the proper spot (located on the network) but the FilePicker just wont open to that location. Now, if I move this Workbook to my direct computer, the FilePicker works as it should. I have not changed anything in the VBA so I don't know why this is all the sudden not working. It worked just last week. Below is the code I believe to be relevant to the issue.
'Creates workpath string
Dim mypath As String, fname As String
mypath = ThisWorkbook.Path
fname = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)
'********************************************************
'Saves PDF with Template Text and Date based on Order Date
Sheets(1).ExportAsFixedFormat 0, mypath & "\" & "TEXT Order Sheet " & Format(Range("D7").Value, "mm-dd-yy")
ActiveSheet.Name = Format(Range("D7").Value, "mm-dd-yy")
'********************************************************
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.Filters.Clear
xFileDlg.Filters.Add "pdf files", "*.pdf"
xFileDlg.AllowMultiSelect = True
xFileDlg.InitialFileName = ThisWorkbook.Path
If xFileDlg.Show = -1 Then
'********************************************************
With xMailOut
.Display
.To = "fake#email.com"
.Subject = "TEXT" & Range("D7").Value
.HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & "Here is our TEXT order for the week of " & Range("D7").Value & "." & " Please respond to this email to confirm that you have received the order." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
'********************************************************

send each sheet to each persons via outlook

I have a master sheet and a code to split it into separate sheet based on reviewer names, now i need to send all the splitted sheet to each of the reviewers based on sheet names, example: sheet named raj must be sent to raj#gmail.com, sheet named ravi must be sent to ravi#gmail.com I managed to find a code to send a single sheet via mail, i need help to send all the sheets to respective persons via outlook.
Attaching the code to send a single sheet.
Sub EmailWithOutlook()
Dim oApp As Object
Dim oMail As Object
Dim WB As Workbook
Dim FileName As String
Dim wSht As Worksheet
Dim ShtName As String
Dim CurrDate As String
CurrDate = format(Date, "MM-DD-YY")
Application.ScreenUpdating = False
' Make a copy of the active worksheet
' and save it to a temporary file
Sheets("raj").Activate
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = WB.Worksheets(1).Name & " " & CurrDate
On Error Resume Next
Kill "C:\Users\Desktop\workfiles\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\Desktop\workfiles\" & FileName
'Create and show the Outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Uncomment the line below to hard code a recipient
.To = "raj#gmail.com"
'Uncomment the line below to hard code a subject
.Subject = "Subject Line"
'Uncomment the lines below to hard code a body
.body = "Hi Raj" & vbCrLf & vbCrLf & _
"Please find the attached file for work"
.Attachments.Add WB.FullName
.Display
End With
'Delete the temporary file
'WB.ChangeFileAccess Mode:=xlReadOnly
'Kill WB.FullName
'WB.Close SaveChanges:=False
'Restore screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
You can iterate over all worksheets in the workbook in the following way to compose an email for each recipient individually:
Set oApp = CreateObject("Outlook.Application")
For i = 1 To WB.Sheets.Count
Set oMail = oApp.CreateItem(0)
With oMail
.To = WB.Sheets(i).Name & "#gmail.com"
.Subject = "Subject Line"
'Uncomment the lines below to hard code a body
.body = "Hi Raj" & vbCrLf & vbCrLf & _
"Please find the attached file for work"
.Attachments.Add WB.FullName
.Send
End With
Next i
You can read more about that in the following articles that I wrote for the technical blog:
How To: Create and send an Outlook message programmatically
How To: Fill TO,CC and BCC fields in Outlook programmatically
How to create and show a new Outlook mail item programmatically: C#, VB.NET

How to insert a table after body of e-mail and before signature?

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.

Paste Excel range as picture into email body

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

VBA convert ThisWorkbook.Path to Hyperlink

i try to send an email via VBA. This email contains the path to the file. But the path is not shown as link to the folder where the file is stored. To be honest i have no idea how to solve this problem and i could not find any solutions so far.
My Code looks like this:
Private Sub CommandButton1_Click()
Dim outlookOBJ As Object
Dim mItem As Object
Set outlookOBJ = CreateObject("Outlook.Application")
Set mItem = outlookOBJ.CreateItem(olMailItem)
With mItem
.To = "Mail.Adress#test.com"
.Subject = "Test"
.Body = "Text Text Text" & ThisWorkbook.Path
ThisWorkbook.Save
.Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
.Send
End With
End Sub
I hope someone can help me that the path will be a clickable link in my email.
thanks a lot

Resources