Problème Mail piece jointe

Bonjour, bonsoir,

Je suis débutant sur excel et j'ai pour projet de réaliser un facturier automatique.

Je suis arrivé à une étape critique, envoyer ma page "Facture" par mail grâce à un btn d'envoi.

Après de nombreuses recherches et de nombreux échecs je suis arrivé à ouvrir ma messagerie Outlook insérer automatiquement le contenu, les adresses mail et le sujet. Me reste plus qu'a joindre la page.

Merci par avance à ceux qui pendront le temps de me lire et si possible de m'aider !

Voici mon code VBA :

Sub EnvoiMail()

'Déclarations'

Dim LeMail As Variant

Dim sFichier As String

Set LeMail = CreateObject("Outlook.Application")

Set MaFeuille = ThisWorkbook.Sheets("Facture")

Sheets("Facture").Select 'Nom exact la feuille

ActiveSheet.Copy 'crée une copie de la feuille active

'Caractèristique du mail'

With LeMail.CreateItem(olMailItem)

.Subject = MaFeuille.Range("D51") & Range("D2")

.To = MaFeuille.Range("D10").Value

.CC = MaFeuille.Range("D11").Value

.Body = MaFeuille.Range("D53").Value

.Display

End With

ActiveWorkbook.SendMail sFichier, Sujet, True

Application.DisplayAlerts = False

ActiveWorkbook.Close 'ferme la copie de la feuille active

Application.DisplayAlerts = True

End Sub

Bonjour Greg17 ,

voici une proposition:

Sub mail()

    Dim MaFeuille As Worksheet, newWbk As Workbook
    Dim OutApp As Object, OutMail As Object
    Dim Destinataire As String, DestCop As String, Sujet As String, Message As String
    Dim Dossier As String, Fichier As String

    Dossier = ThisWorkbook.Path & "\"
    Set MaFeuille = ThisWorkbook.Sheets("Facture")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    MaFeuille.Copy
    Set newWbk = ActiveWorkbook
    Fichier = Dossier & "Facture" & ".xlsx" 'Nom du fichier à adapter

    With newWbk
        .SaveAs FileName:=Fichier
        .Close SaveChanges:=False
    End With

    Destinataire = MaFeuille.Range("D10").Value
    DestCop = MaFeuille.Range("D11").Value
    Sujet = MaFeuille.Range("D51") & MaFeuille.Range("D2")
    Message = MaFeuille.Range("D53").Value

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Destinataire
        .CC = DestCop
        .Subject = Sujet
        .Body = Message
        .Attachments.Add Fichier
        .Display
        ' .Send 'Pour envoi automatique
    End With

    On Error GoTo 0

    Kill Fichier

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True

    End With

End Sub

Cordialement.