Code envoi mail

[castor30]

Bonjour le forum,
Avec le code joint (je ne peux mettre le fichier) qui fonctionne en apparence, le corps du texte est tronqué. Pourquoi ?
En vous remerciant.

Sub Envoidu_MailAutomatique2()
    'On Error Resume Next
    ' Touche de raccourci du clavier: Ctrl+e
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim PJ As String        'Piece-Jointe=OUI/NON
    Dim List_To As String, List_Cop As String

    UF_Attente.Show vbModeless

    'ici je repère la dernière ligne vide pour la Collection des données
    List_To = "": List_Cop = ""
    With Worksheets("Mail")
        derlig = Range("N" & Rows.Count).End(xlUp).Row
        If derlig > 2 Then
            For n = 3 To derlig
                List_To = List_To & .Cells(n, "N") & "; "
            Next n
            List_To = Left(List_To, Len(List_To) - 1) & vbTab
        Else
            MsgBox "Attention: pas de destinataire!!!!"
            Exit Sub
        End If
        derlig = Range("O" & Rows.Count).End(xlUp).Row
        If derlig > 2 Then
            For n = 3 To derlig
                List_Cop = List_Cop & .Cells(n, "O") & ";"
            Next n
            List_Cop = Left(List_Cop, Len(List_Cop) - 1) & vbTab
        End If
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    'contenu Message
    With Worksheets("Mail")
        PJ = .Range("M2")
        Sujet = .Range("J3")
        strbody = .Shapes("CorpsMessage").TextFrame.Characters.Text & vbTab
    
    End With
    With OutMail
        .To = List_To
        .CC = List_Cop
        .BCC = ""
        .Subject = Sujet
        .Body = strbody
        'You can add a file like this
        If UCase(PJ) = "OUI" Then
            .Attachments.Add (Worksheets("Mail").Range("M3").Value)      'mettre ce que vous voulez !!!!!!!!!!!!!!!!!!!!
        End If
        '.Display
        'or use
        .Send
    End With
    'attente envoi @Mail par Outlook
    'Application.Wait Application.Wait(Now + TimeValue("0:00:01"))
    Set OutMail = Nothing
    Set OutApp = Nothing
    Unload UF_Attente
       ' Message de confirmation d'envoi
       MsgBox "Le mail a été envoyer"
End Sub

 

[castor30]

J'ai mis le fichier
j'ouvrirai une autre adresse mail demain car problème avec
Merci de ta patience

 

[Staple1600]

Re

Ok pour le fichier.
Mais quelle est la question?
Le code que j'ai soumis en novembre 2017 ne fonctionne pas?

 

[castor30]

Non, ne fonctionne pas car j'ai du oublier quelque chose

il bloque ici
End If
'.Display
'or use
.Send mail
End With

Nouveau fil ici :
https://www.excel-downloads.com/threads/envoi-mail-cdo.20022004/