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

[Sleeplol]

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

'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

 

[dangelor]

Possibly using a timestamp embedded into the file name...

Filename:=PdfFile & " Pass On " [COLOR="#FF0000"]& Format(Now, "yyyymmdd hhmmss") &[/COLOR] ".pdf"

 

[Sleeplol]

Possibly using a timestamp embedded into the file name...

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]

Try:

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

 

[Sleeplol]

Sweet, thanks Tom

 

[Sleeplol]

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

'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

 

[John_w]

Try replacing:

  ' 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:

    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]

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]

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]

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.