Create email with all currently selected sheets attached as individual pdf files

[Yamezz]

I need to create an email with all the currently selected sheets attached as individual pdf files.

My workflow thoughts are to:
Create an email
For each selected sheet
Export selected sheet as individual pdf file
Set the email subject to "LIP " & append the sheet name
Add the exported pdf file as an attachment
Next selected sheet

Sometimes I will have just one sheet to export, other times I'll have an unknown number to export.

I have an existing functioning macro that will export one selected sheet and create one email. I have only a vague idea of how to change this to add multiple sheets. I have tried modifying my working code and changing the order of operations but I'm not making much progress.
Thanks for any help

Sub Export2()
Dim FName As String, SheetName As String, DateStamp As Date, ws As Worksheet

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
With Outlapp.CreateItem(olMail)
    .Subject = "LIP " & SheetName
End With
  
For Each ws In activewindows.SelectedSheets
    ws.Copy
    SheetName = ActiveSheet.Name
    DateStamp = Range("B1").Value
    FName = "C:\Output\" & "LIP" & " " & SheetName & " " & Format(DateStamp, "yyyymmdd") & ".pdf"
    Application.ActivePrinter = "Microsoft Print to PDF on Ne02:"
    
    ' EXPORT AS PDF
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=FName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
    
    ActiveWorkbook.Close SaveChanges:=False
    
    olMail.Attachments.Add (FName)
    
Next ws

Outlapp.Visible = True

With olMail
    On Error Resume Next
    Application.Visible = True
    .Display
End With
 
  Set Outlapp = Nothing
End Sub

 

[John_w]

Try this macro.

Public Sub Create_Email_Attach_Selected_Sheets()

    Dim FName As String, SheetNames As String
    Dim ws As Worksheet
    Dim OutApp As Object, OutEmail As Object
    Dim selSheets As Sheets
    
    Const olMail = 0
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set OutEmail = OutApp.CreateItem(olMail)
    
    SheetNames = ""
    Set selSheets = ActiveWindow.SelectedSheets
    For Each ws In selSheets
        SheetNames = SheetNames & ws.Name & ", "
        FName = "C:\Output\LIP " & ws.Name & " " & Format(ws.Range("B1").Value, "yyyymmdd") & ".pdf"
        ws.Select
        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        OutEmail.Attachments.Add FName
    Next ws
    
    selSheets.Select
    
    With OutEmail
        .Subject = "LIP " & Left(SheetNames, Len(SheetNames) - 2)
        .Display
    End With
     
    Set OutApp = Nothing
    
End Sub

 

[Yamezz]

Thank you John. That's great!