Envoi objet d'Excel vers Outloock - un peu galére !

Public NomGlobal
Sub envoi_Feuille()
    SauveImage
    Copier_Feuille_Dans_Fichier
    '---  Envoi par mail
    Dim olapp As Outlook.Application
    Sheets("destinataires").Select
    Range("A11").Select
    'Do While Not IsEmpty(ActiveCell)
    Dim msg As MailItem
    Set olapp = New Outlook.Application
    Set msg = olapp.CreateItem(olMailItem)
    msg.To = ActiveCell.Value
    msg.Subject = Range("A2").Value
    msg.Body = Range("A5").Value & Chr(13) & Chr(13) & Range("A8").Value & Chr(13) & Chr(13)
    msg.Attachments.Add NomGlobal
    msg.Attachments.Add ("C:\Temp\Temp.jpg")
    'msg.Send
    msg.Display
    ActiveCell.Offset(1, 0).Select
    'Loop
End Sub
Sub SauveImage()
    Dim Img As Object
    Set Img = Sheets("IMAGE").Shapes("Picture 1")
    Img.Copy
    Set ch = Sheets("IMAGE").ChartObjects.Add(0, 0, Img.Width, Img.Height)
    ch.Border.LineStyle = 0
    ch.Chart.Paste
    ch.Chart.Export "C:\Temp\Temp.jpg", FilterName:="JPEG"
    ch.Delete
End Sub
Sub Copier_Feuille_Dans_Fichier()
    DossierPath = "C:\Temp"
    Dim ws As Worksheet
    Sheets(2).Activate
    NomFichier = Sheets(2).Name
    Sheets(2).Copy
    ActiveSheet.SaveAs Filename:= _
                       DossierPath & "\" & NomFichier, FileFormat:= _
                       xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.Close
    NomGlobal = DossierPath & "\" & NomFichier & ".xlsm"
End Sub