VBA - Send Email with PDF attached + picture/table in the body

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
24
Hi,

I want to send an Outlook email from my workbook with:
1. a PDF attached = from one workbook sheet called "DbD Month".
2. a picture of a table in a range in the sheet called "Pickup".

The current challenges are:
1. My current Macro pastes the "pickup" table in the Body but the size is not userfriendly, plus it shows many hidden lines.
Therefore, I was thinking to add a picture in the body to fix this issue.

2. I would like to delete my PDF after it is sent.
3. I do not have the technical skills to create a new function to save the rng as a picture and then add it in the body.


Please see the current code below:


Option Explicit


Sub SveShts()


Dim xPath As String
Dim xWs As String


'Establish location of this workbook
xPath = Application.ActiveWorkbook.Path


Application.ScreenUpdating = False
Application.DisplayAlerts = False


'Copy specified sheet to be attached to email. Edit sheet name as required. Sheet is saved as a XLSX workbook
'in same location as this workbook
With Sheets("DbD Month")
Sheets("DbD Month").Copy
Application.ActiveWorkbook.SaveAs FileName:=xPath & "" & ActiveSheet.Name & ".pdf"
Application.ActiveWorkbook.Close False
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'Call the CopyRows macro (below)
CopyRows
End Sub


'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Pickup") '<<-- edit sheet name as required
ws1.Range("B1:AD38").Copy
Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String


Dim xPath As String
Dim xWs As String


xPath = Application.ActiveWorkbook.Path


Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Pickup").Range("B1:AD38") '<<----- edit range as required


If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If


'Turn off screen updating to prevent flickering / flashing
With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
.To = "mcp.boucher@gmail.com"
.CC = ""
.BCC = ""
.Subject = "Daily Report - Catala Consulting"


.HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
RangetoHTML(rng) & "<br><br>" & _
"Text below Excel cells.</p>"
'.Attachments.Add "C:\Users\Utilisateur\Documents\Green Square\Daily Reports\PDF\DbD Month.pdf" '<<--- edit path as required

' In place of the following statement, you can use ".Send" to
' Send the e-mail message.
.Display
End With


On Error GoTo 0


'Turn on screen updating
With Application
.EnableEvents = True
.ScreenUpdating = True
End With


'Delete the temporary .xlsx file created for attachment
Kill "C:\Users\Utilisateur\Documents\Green Square\Daily Reports\PDF\*.pdf"


Set OutMail = Nothing
Set OutApp = Nothing


End Sub


''<<<>>> There is no need to edit anything in this Function.


Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy

Set TempWB = Workbooks.Add(1)

With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,923
Office Version
2007
Platform
Windows
Check the following:
- I join the macros to save the file and put the range in the mail.
- I put the instruction to delete (kill) the pdf
- In the RangetoHTML function, I added some lines for you to modify, you can put one or more criteria to delete the rows, that way you will delete the rows that you do not want to put in the body of the mail.
- Test and comment. Either way a 30 column image, I don't think it looks good either.

Code:
Option Explicit
'
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  Dim lEndRow
  Dim Value As String
  Dim xPath As String, [COLOR=#0000ff]xFile As String[/COLOR]
  Dim xWs As String
  'Turn off screen updating to prevent flickering / flashing
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
  End With
[COLOR=#0000ff]  'save pdf file[/COLOR]
  xPath = Application.ActiveWorkbook.Path
  With Sheets("DbD Month")
    .Copy
    xFile = xPath & "\" & .Name & ".pdf"
[COLOR=#0000ff]    Application.ActiveWorkbook.SaveAs Filename:=xFile[/COLOR]
    Application.ActiveWorkbook.Close False
  End With
  '
  Set rng = Nothing
  ' Only send the used cells in the sheet
  Set rng = Sheets("Pickup").Range("B1:AD38") '<<----- edit range as required
  If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
  End If
  '
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  With OutMail
    .To = "mcp.boucher@gmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "Daily Report - Catala Consulting"
    .HTMLBody = "Text above Excel cells" & RangetoHTML(rng) & "Text below Excel cells."
    .Attachments.Add xFile
    ' In place of the following statement, you can use ".Send" to send
    '.Send
    .Display
  End With
  On Error GoTo 0
  'Turn on screen updating
  With Application
    .EnableEvents = True
    .ScreenUpdating = True
  End With
  'Delete the temporary .xlsx file created for attachment
[COLOR=#ff0000]  Kill xFile[/COLOR]
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
'
Function [COLOR=#0000cd]RangetoHTML[/COLOR](rng As Range)
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  'Copy the range and create a new workbook to past the data in
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
[COLOR=#0000cd]    'Delete lines according to criteria.[/COLOR]
[COLOR=#0000cd]    Dim i As Long[/COLOR]
[COLOR=#0000cd]    For i = rng.Rows.Count To 1 Step -1[/COLOR]
[COLOR=#0000cd]      If .Cells(i, "D").Value = "" Or .Cells(i, "D").Value = 0 Then[/COLOR]
[COLOR=#0000cd]        .Rows(i).Delete[/COLOR]
[COLOR=#0000cd]      End If[/COLOR]
[COLOR=#0000cd]    Next[/COLOR]
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With
  'Publish the sheet to a htm file
  With TempWB.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With
  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")
  'Close TempWB
  TempWB.Close savechanges:=False
  'Delete the htm file we used in this function
  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function
 

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
24
Hi Dante,

Thanks for this, it is very helpfull! I have an issue with the PDF file. It is corrupted and cannot be open.
Also, is there an option to insert the table as a picture in the body?

Please find the code in use below:

ption Explicit
'
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Dim xPath As String, xFile As String
Dim xWs As String


'Turn off screen updating to prevent flickering / flashing
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'save pdf file
xPath = "C:\Users\Utilisateur\Documents\Daily Reports\Send Gmail Using VBA\PDF"
With Sheets("DbD Month")
.Copy
xFile = xPath & "" & .Name & " " & Format(Now, "dd-mm-yyyy") & ".pdf"
Application.ActiveWorkbook.SaveAs FileName:=xFile
Application.ActiveWorkbook.Close False
End With
'
Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("ToMail").Range("A1:Q31") '<<----- edit range as required
If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "Thibault@gmail.com"
.CC = ""
.BCC = ""
.Subject = "Daily Report - TEST"
.HTMLBody = "Good morning," & "<br><br>" & _
"Please find below the latest daily reports updated today:" & "<br><br>" & _
Sheets("ToMail").Range("A33") & "<br><br>" & _
Sheets("ToMail").Range("A34") & "<br><br>" & _
RangetoHTML(rng) & _
"Kind regards."


.Attachments.Add xFile
' In place of the following statement, you can use ".Send" to send
'.Send
.Display
End With
On Error GoTo 0
'Turn on screen updating
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
'Delete the temporary .xlsx file created for attachment
'Kill xFile
Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
'Delete lines according to criteria.


On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,923
Office Version
2007
Platform
Windows
Change this

Code:
  With Sheets("DbD Month")
    .Copy
    xFile = xPath & "\" & .Name & ".pdf"
    Application.ActiveWorkbook.SaveAs Filename:=xFile
    Application.ActiveWorkbook.Close False
  End With
For this:

Code:
  With Sheets("DbD Month")
    .Copy
    xFile = xPath & "\" & .Name & ".pdf"
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=strDir & fName, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
24
I have a Run-time Error with the Method 'ExportAsFixedFormat' of objetct_'Workook' failed.

My current code:

With Sheets("DbD Month") .Copy
xFile = xPath & "" & .Name & ".pdf"
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=xPath & xFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,923
Office Version
2007
Platform
Windows
Sorry, It must be like that

Code:
  'save pdf file
  xPath = Application.ActiveWorkbook.Path
  With Sheets("DbD Month")
    .Copy
    [COLOR=#0000ff]xFile [/COLOR]= xPath & "\" & .Name & ".pdf"
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=[COLOR=#0000ff]xFile[/COLOR], _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    ActiveWorkbook.Close False
  End With
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,923
Office Version
2007
Platform
Windows
Also, is there an option to insert the table as a picture in the body?
Try the following to insert the image into the email:

Code:
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range, OutApp As Object, OutMail As Object
  Dim xPath As String, xFile As String, h2 As Worksheet
  'Turn off screen updating to prevent flickering / flashing
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  'save pdf file
  xPath = Application.ActiveWorkbook.Path
  With Sheets("DbD Month")
    .Copy
    xFile = xPath & "\" & .Name & ".pdf"
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFile, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    ActiveWorkbook.Close False
  End With
  '
  Set rng = Nothing
  Set rng = Sheets("Pickup").Range("B1:AD38") '<<----- edit range as required
  If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
  End If
  '
  'save table as a picture
  Set h2 = Sheets.Add
  rng.CopyPicture
  h2.Shapes.AddChart
  With h2.ChartObjects(1)
      .Width = rng.Width
      .Height = rng.Height
      .Chart.Paste
      .Chart.Export xPath & "\" & "logo.jpg"
      .Delete
  End With
  h2.Delete
  '
  Set OutMail = CreateObject("Outlook.Application").CreateItem(0)
  With OutMail
    .To = "mcp.boucher@gmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "Daily Report - Catala Consulting"
[COLOR=#0000ff]    .HTMLBody = " < html > " & " < body > " & "Text above Excel cells  < br > " & _[/COLOR]
[COLOR=#0000ff]                    " < img src=cid:logo.jpg height=300 width=600 > " & _[/COLOR]
[COLOR=#0000ff]                    " < br >  Text below Excel cells." & _[/COLOR]
[COLOR=#0000ff]                    " < /body > " & " < /html > "[/COLOR]
    .Attachments.Add xPath & "\" & "logo.jpg"
    .Attachments.Add xFile
    .Display '.Send In place of the following statement, you can use ".Send" to send
  End With
  On Error GoTo 0
  'Turn on screen updating
  Application.EnableEvents = True
  'Delete the temporary files
  Kill xFile
  Kill xPath & "\" & "logo.jpg"
  Set OutMail = Nothing
End Sub
------------------
Please check the following.
The forum editor always changes the HTML code.
So in these lines you must remove the spaces I put before and after each sign < > .



Code:
[COLOR=#0000FF]    .HTMLBody = " < html > " & " < body > " & "Text above Excel cells  < br > " & _[/COLOR]
[COLOR=#0000FF]                    " < img src=cid:logo.jpg height=300 width=600 > " & _[/COLOR]
[COLOR=#0000FF]                    " < br >  Text below Excel cells." & _[/COLOR]
[COLOR=#0000FF]                    " < /body > " & " < /html > "[/COLOR]
 

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
24
This is amazing, thank you Dante.

Although, I adjusted the rng variable, the picture in the email's body is blank. I tired different ranges but it didn't solve the issue.
Do you have any chance what might cause this glitch?
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,923
Office Version
2007
Platform
Windows
Works for me, it looks like this:




_-------------------------------------------------------------------

Check the HTML code, it should look like this:

 

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
24
Hi Dante,

I managed to get the code to work after couple of reviews!

Many thanks for helping, I have learn so much.

Best,
Matt
 

Forum statistics

Threads
1,078,466
Messages
5,340,484
Members
399,378
Latest member
voodoo1

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top