VBA to Copy specified worksheets into a new workbook and attach to email

[Mindb85]

Hello,

I have the attached code which pretty much does what I want but I require assistance in changing it so that it no longer produces a PDF but instead attaches the specified worksheets as .xls files.

Any assistance would be greatly appreciated

Sub Attach_Sheets_As_Pdf_With_Signature()
' ZVI:2016-09-20 [URL]http://www.mrexcel.com/forum/excel-questions/710212-visual-basic-applications-code-convert-excel-pdf-email-attachment-5.html#post4636678[/URL]
 
  ' --> User settings, change to suit
  Const MySheets As Variant = "SUMMARY,PAYROLL,MILEAGE,OVERTIME" ' Use MySheets = 0 for all the sheets
  Const IsDisplay As Boolean = True           ' Change to False to .Send instead of .Display
  Const IsSilent As Boolean = True           ' Change to True to Send without the confirmation MsgBox
  ' <-- End of settings
 
  Dim IsCreated As Boolean
  Dim PdfFile As String, Signature As String
  Dim OutlApp As Object
  Dim i As Long
  Dim char As Variant
 
  ' Define PDF filename
  PdfFile = ActiveWorkbook.Name
  i = InStrRev(PdfFile, ".xl", , vbTextCompare)
  If i > Len(PdfFile) - 5 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name
  ' Clean up the name of PDF file
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
  ' Add %TEMP% path to the file name and limit too long name
  PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "" & PdfFile, 251) & ".pdf"
 
  ' Try to delete PDF file for the case it was not deleted at debugging
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Select sheets to be exported in the PDF (single) file
  If MySheets = 0 Then
    ' All sheets to PDF
    Sheets.Select
  Else
    ' Sheets listed in MySheets to PDF
    Sheets(Split(MySheets, ",")).Select
  End If
 
  ' Export the selected sheets as PDF to the temporary folder
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    .Select
  End With
 
  ' Use the 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 email with PDF attachment and default signature
  With OutlApp.CreateItem(0)
  
    ' Add the attachment first for correct attachment's name with non English symbols
    .Attachments.Add PdfFile
  
   ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    Signature = .HTMLBody
 
    ' Prepare e-mail (uncommenmt and fill the lines below)
    .Subject = "Staffing"
    .To = Range("I3").Value
    .CC = Range("I4").Value
     Message = "****** style=font-size:11.5pt;font-family:GillSansMT>Hi" & vbLf & vbLf _
            & "****** style=font-size:11.5pt;font-family:GillSansMT>Please find attached the Payroll Monitoring for your relevant departments to " & Sheets("LkUps").Range("C5").Value & ". This will be reflected in the " & Sheets("LkUps").Range("C5").Value & " Budget Monitoring Statement. The attached documents show the overall total payroll costs together with a summary of any overtime and mileage payments made." & vbLf & vbLf _
            & "****** style=font-size:11.5pt;font-family:GillSansMT>It is important that you let us know if anything is incorrect as soon as possible so we can correct it in time for budget monitoring.  If you have any queries, please contact a member of the Finance Team. The format has changed slightly and we are now sending it out as a pdf, as this allows us to work more efficiently and therefore send it out before budget monitoring.  If this creates any problems please let me know and I will try to resolve them." & vbLf & vbLf _
            & "****** style=font-size:11.5pt;font-family:GillSansMT>Kind Regards"
    .HTMLBody = Replace(Message, vbLf, Chr(60) & "br" & Chr(62)) & Signature
  
    ' Try to send or just display the e-mail
    On Error Resume Next
    If IsDisplay Then .Display Else .Send
  
    ' Show error of .Send method
    If Not IsDisplay Then
      ' Return focus to Excel's window
      Application.Visible = True
      ' Report on error or success
      If Err Then
        MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
        .Display
      Else
        If Not IsSilent Then
          MsgBox "E-mail successfully sent", vbInformation
        End If
      End If
    End If
    On Error GoTo 0
 
  End With
 
  ' Delete the temporary PDF file
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Try to quit Outlook if it was not previously open
  If IsCreated Then OutlApp.Quit
 
  ' Try to release the memory of object variable
  Set OutlApp = Nothing
 
End Sub

Regards

Will

 

[Krayons]

Change the type from xlTypePDF to xlTypeXPS

' Export the selected sheets as PDF to the temporary folder
With ActiveSheet
     .ExportAsFixedFormat Type:=xlTypeXPS, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
.Select
End With

 

[Mindb85]

Change the type from xlTypePDF to xlTypeXPS

' Export the selected sheets as PDF to the temporary folder
With ActiveSheet
     .ExportAsFixedFormat Type:=xlTypeXPS, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
.Select
End With

Do I need to adjust anything else? It is coming back with the following error message

Run-time error '-2147024894(80070002)':

Cannot find this file. Verify the path and file name are correct.

Regards

Will

 

[Krayons]

Replace:

PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "" & PdfFile, 251) & ".pdf"

With:

PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "" & PdfFile, 251) & ".xlsm"

 

[Mindb85]

I have amended the code as above however it is still returning the same error message.

when I go into Debug mode it is highlighting .Attachments.Add PdfFile

Do you have any further suggestions?

Regards

Will