PDF to email then save and titled per send date

[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
• Not auto saving with current date and shift (i.e.4/10/2019 Day, 4/10/2019 Night)

Help would be greatly appreciated.

Brian

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

 

[Sleeplol]

I'm not sure how this post managed to end up here; I apologize.