Excel sheet[s] converted to PDF, Saved, then attached to Outlook and sent

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello All,
I just signed up and I know it looks bad that my first post is asking for a favor, but I could really use one.
The workbook is for Pass-On reports, both Day and Night shift.
Needs:
Push Button
  • Convert active sheet to PDF
  • Send to desired Pass-On Group
  • Save PDF titled with current date to file that houses this workbook
(Nightshift would be saved under the previous day’s date)

The goal is to have a file loaded with Daily Pass-On reports for Day and Night shift.

Currently code is:
  • Overwriting old PDF in file with the most recently sent

Help would be greatly appreciated.

Brian

Code:

Sub printSelection()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, signature As String
Dim OutlApp As Object
Dim RngCopied As Range


Set RngCopied = Selection

' pdf path and filename
Title = Range("B11") & " Pass On"
With ThisWorkbook
PdfFile = .Path & Application.PathSeparator & _
.Sheets("DayShift").Range("B11")
End With

With ActiveSheet.PageSetup
.FitToPagesWide = 1
.Zoom = False
End With

' Export activesheet as PDF to the current folder
With ActiveSheet
Range("A1:G68").Select
'Will need to fix this and add auto date and no file replace
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile & " Pass On.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End With

With ThisWorkbook
PdfFile = PdfFile & " Pass On.pdf"
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

.Display ' We need to display email first for signature to be added
.Subject = Title
.To = "Brian_Warner@Cascades.com" ' <-- Put email of the recipient here or use a cell value
.CC = "" ' <-- Put email of 'copy to' recipients here
.HTMLBody = "Pass On Report " & ActiveSheet.Range("B9").Value & ". " & " This report is for the Maintenance Pass On Group only." & _
vbNewLine & vbNewLine & _
RangetoHTML(RngCopied) & _
"Thank you," & _
.HTMLBody ' Adds default outlook account signature
.Attachments.Add PdfFile


On Error Resume Next


' Return focus to Excel's window
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
' Note: sometimes Outlook object can't be released from the memory
Set OutlApp = 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 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 used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

dangelor

Board Regular
Joined
May 6, 2005
Messages
138
Possibly using a timestamp embedded into the file name...
Code:
Filename:=PdfFile & " Pass On " [COLOR="#FF0000"]& Format(Now, "yyyymmdd hhmmss") &[/COLOR] ".pdf"
 

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Possibly using a timestamp embedded into the file name...
Code:
Filename:=PdfFile & " Pass On " [COLOR=#ff0000]& Format(Now, "yyyymmdd hhmmss") &[/COLOR] ".pdf"

Dangelor, Thank you. This exactly what I needed. Thanks for taking the time. However, I have 1 question. How can I set that date for "yesterday's" date? My reasoning is that this is for a Pass-On report from night shift e.g. they start at 9pm on 4/10/2019 and get off at 9am 4/11/2019; the pass-on needs to reflect the 4/10 shift start date.
 

Tom.Jones

Active Member
Joined
Sep 20, 2011
Messages
338
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Try:

Filename:=PdfFile & " Pass On " & Format(Now - 1, "yyyymmdd hhmmss") & ".pdf"
 

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows

ADVERTISEMENT

Sweet, thanks Tom
 

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello again, the code was working perfectly, converting to pdf, saving time stamped pdf, attaching pdf to email. Then I would manually press the send button. Now, suddenly, I get the Run-Time error '2147024894 (80070002)' The file is still converting to a pdf, and it's saving to the designated folder, but it is no longer attaching the pdf. If the pdf file is where it needs to be I don't understand why Outlook is not finding it. I would really appreciate some help with this. Also, the Outlook will pull up while an hour-glass sits on excel. Could it be that the program is outpacing the system, so it tries to pull the file before it has been saved? I'm stumped. Please shed some light on this. The code below Sub printSelectionNight()
Application.ScreenUpdating = False
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, signature As String
Dim OutlApp As Object
Dim RngCopied As Range


Set RngCopied = Selection

' pdf path and filename
Title = Range("A1,D1") & " Pass On"
With ThisWorkbook
PdfFile = .Path & Application.PathSeparator & _
.Sheets("NightShift").Range("D1")
End With

With ActiveSheet.PageSetup
.FitToPagesWide = 1
.Zoom = False
End With

' Export activesheet as PDF to the current folder
With ActiveSheet
Range("A1:G56").Select
'Will need to fix this and add auto date and no file replace ok fixed now
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile & " Pass On " & Format(Now() - 1, "yyyy mmdd hhmmss") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

With ThisWorkbook
PdfFile = PdfFile & " Pass On.pdf"
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

.Display ' Verify Email display, so 2 buttons lol
.Subject = Title
.To = "" ' <-- Email need to allow Groups to be dynamic
.CC = "" '
.HTMLBody = "Pass On Report " & ActiveSheet.Range("D1").Value & ". " & " This report is for the Maintenance Pass On Group only." & _
vbNewLine & vbNewLine & _
RangetoHTML(RngCopied) & _
"Thank you," & _
.HTMLBody ' Adds default outlook account signature
.Attachments.Add PdfFile What debugger highlights


On Error Resume Next


' Return focus to Excel's window
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit

' Release the memory of object variable

Set OutlApp = Nothing


End Sub


Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
'added this so that files will not be overwritten and it gives a time stamp fyi Night Shift is minus a day
TempFile = Environ$("temp") & "/" & Format(Now() - 1, "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 used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 
Last edited:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,712

ADVERTISEMENT

Try replacing:
Code:
  ' Export activesheet as PDF to the current folder
  With ActiveSheet
    Range("A1:G56").Select
    'Will need to fix this and add auto date and no file replace ok fixed now
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile & " Pass On " & Format(Now() - 1, "yyyy mmdd hhmmss") & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
  
   With ThisWorkbook
    PdfFile = PdfFile & " Pass On.pdf"
    End With
with:
Code:
    PdfFile = PdfFile & " Pass On " & Format(Now() - 1, "yyyy mmdd hhmmss") & ".pdf"
    ' Export activesheet as PDF to the current folder
    With ActiveSheet
        Range("A1:G56").Select
        'Will need to fix this and add auto date and no file replace ok fixed now
        Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
Please use CODE tags - click the # icon in the message editor.
 

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi John, Thank you, this worked fantastically. I'm not sure why your code is working so well and the other was not. Also, next time I will use CODE tags; thank you.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,712
Look carefully at the PdfFile variable and think about what it contains at each line which uses it. My code works because PdfFile contains the file name used to create the PDF and the variable has the same value at the Attachments.Add line.
 

Sleeplol

Board Regular
Joined
Apr 10, 2019
Messages
121
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Ok, so I was looking for a file that wasn't there, where as yours is looking for PdfFile which is what the attachment is named. Got it! Thank you for taking that time.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,422
Messages
5,624,697
Members
416,042
Latest member
Oden

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top