Microsoft 365 Joindre une copie de 2 feuilles Excel dans outlook

[Mika07]

Bonjour à tous

Je souhaite faire évoluer ce code.

J'aimerais savoir s'il est possible de joindre 2 feuilles de mon classeur en .xls. dans le mail en plus du .PDF.
Cependant les feuilles comportent des liens qui doivent être rompus/figé

Sub Saveandsendtech()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xSheet As Worksheet
Dim xSheetName As Variant
Dim xLastRow As Long
Dim xIndex As Long
Dim xSheetsArray() As String

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + Range("A1") + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

'Retrieve the sheet names from column I
    xLastRow = xSht.Cells(xSht.Rows.Count, "I").End(xlUp).Row
        ReDim xSheetsArray(1 To xLastRow - 1) As String
    For xIndex = 2 To xLastRow
        xSheetsArray(xIndex - 1) = xSht.Cells(xIndex, "I").Value
    Next xIndex

    Set xUsedRng = xSht.UsedRange

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Select sheets based on the names in the array
    For Each xSheetName In xSheetsArray
    On Error Resume Next
    Set xSheet = Worksheets(xSheetName)
    If Err.Number = 0 Then
    xSheet.Select Replace:=False
    End If
    On Error GoTo 0
    Next xSheetName
    'Save as PDF file
    Sheets(xSheetsArray).Select
    Sheets(xSheetsArray(1)).Activate
    Application.PrintCommunication = False
     With ActiveSheet.PageSetup
      .LeftMargin = Application.InchesToPoints(0.1)
      .RightMargin = Application.InchesToPoints(0.1)
      .TopMargin = Application.InchesToPoints(0)
      .BottomMargin = Application.InchesToPoints(0)
      .HeaderMargin = Application.InchesToPoints(0)
      .FooterMargin = Application.InchesToPoints(0)
      .Orientation = xlPortrait
      .PaperSize = xlPaperA4
      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .CenterHorizontally = True
      .CenterVertically = False
      .Order = xlDownThenOver
      .Draft = False
      .Zoom = False
      .FitToPagesTall = 0
      .FitToPagesWide = 1
    End With
    Application.PrintCommunication = True
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Sheets(Array("Sommaire")).Select
   
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .to = Range("C5")
        .cc = Range("C6")
        .bcc = Range("C7")
        .Subject = Range("C8")
        .HTMLBody = "<FONT size=3>" & Range("C9") & "<br>" _
                    & "<br>" _
                    & Range("C10") & .HTMLBody
       
        .Attachments.Add xFolder
               
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else

  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub