Envoyer mail Outlook, coller photo automatique

Bonjour le Forum,

Avec l'aide de ChatGPT et Chat Mistral, j'ai créé un code qui me permet, lorsque j'appuie sur un bouton dans ma feuille Excel, de rédiger automatiquement un e-mail Outlook et de copier une plage de données de ma feuille pour ensuite la coller dans le corps du mail. Cependant, c'est cette dernière étape qui ne parvient pas à se réaliser automatiquement. Je suis obligé de faire un Ctrl+V dans mon e-mail pour coller l'image.

Sub btnEnvoyerMail_Click()
    ' Demander à l'utilisateur s'il souhaite envoyer le mail
    Dim confirmation As VbMsgBoxResult
    confirmation = MsgBox("Voulez-vous envoyer un e-mail avec le tableau de marche ?", vbYesNo + vbQuestion, "Confirmation")

    If confirmation <> vbYes Then
        Exit Sub
    End If

    ' Déclarer les variables
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim WordDoc As Object
    Dim WordRange As Object

    ' Référencer la feuille active
    Set ws = activeSheet

    ' Copier la plage en conservant les mises en forme
    ws.Range("A3:CB49").CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' Créer une instance d'Outlook et un nouveau mail
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    ' Accéder au corps du mail en mode édition
    With OutlookMail
        .Display
        Set WordDoc = .GetInspector.WordEditor
        Set WordRange = WordDoc.Range
    End With

    ' Insérer le tableau dans le corps du mail
    WordRange.Collapse Direction:=0 ' Direction: 0 = wdCollapseEnd (à la fin du corps du mail)
    WordRange.Paste

    ' Préparer le corps du mail
    With OutlookMail
        .Subject = "Tableau de marche " & ws.Name
        .To = "loic@test.fr;toto@test.fr"
        .HTMLBody = "Bonjour," & vbCrLf & vbCrLf & _
                "Voici le tableau de marche pour la journée du " & ws.Name & "." & vbCrLf & vbCrLf & _
                "Cordialement,"
        .Display ' Afficher le brouillon du mail pour permettre à l'utilisateur de le vérifier avant envoi
    End With

    ' Libérer les objets Outlook et Word
    Set WordRange = Nothing
    Set WordDoc = Nothing
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Merci pour votre aide.

Cordialement,

Bonsoir,

ci-joint code corrigé

Sub btnEnvoyerMail_Click()
    ' Demander à l'utilisateur s'il souhaite envoyer le mail
    Dim confirmation As VbMsgBoxResult
    confirmation = MsgBox("Voulez-vous envoyer un e-mail avec le tableau de marche ?", vbYesNo + vbQuestion, "Confirmation")

    If confirmation <> vbYes Then
        Exit Sub
    End If

    ' Déclarer les variables
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim WordDoc As Object
    Dim WordRange As Object
    Dim plage_à_copier As Range

    ' Référencer la feuille active
    Set ws = ActiveSheet

    ' Définir la plage à copier
    Set plage_à_copier = ws.Range("A3:CB49")

    ' Créer une instance d'Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    ' Vérifier la présence d'un explorateur Outlook
    If OutlookApp.Explorers.Count = 0 Then
        OutlookApp.Session.GetDefaultFolder(olFolderInbox).Display
        OutlookApp.ActiveExplorer.WindowState = olMinimized
    End If
    ' Créer un nouveau mail
    Set OutlookMail = OutlookApp.CreateItem(0)

    ' Remplissage du mail
    With OutlookMail

        'Sujet, destinataire, signature
        .Subject = "Tableau de marche " & ws.Name
        .To = "loic@test.fr;toto@test.fr"
        .Display    'affichage pour insertion signature

        'Corps du mail
        Set WordDoc = .GetInspector.WordEditor
        Set WordRange = WordDoc.Range(0, 0)
        With WordRange
            .Text = "Bonjour," & vbCrLf & vbCrLf
            .Text = .Text & "Voici le tableau de marche pour la journée du " & ws.Name & "." & vbCrLf & vbCrLf
            .Move 4, 1

            ' Insérer le tableau dans le corps du mail
            plage_à_copier.Copy
            .Paste
            .Move 4, 2

            .Text = "Cordialement," & vbCrLf
        End With

        .Display ' Afficher le brouillon du mail pour permettre à l'utilisateur de le vérifier avant envoi

    End With

    ' Libérer les objets Outlook et Word
    Set WordRange = Nothing
    Set WordDoc = Nothing
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

Merci Thev