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