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

[Mathexcel]

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 xublishsource=", _
"align=left xublishsource=")
'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]

I'm glad to know that it works for you. Thanks for the feedback.