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

 

[Staple1600]

Bonsoir le fil, le forum

@castor30
Bien sur que tu peux envoyer un fichier exemple.
Il suffit de l’anonymiser avant envoi 🙄

En attendant un éventuel fichier exemple, je te propose cette autre façon (sans boucle) de créer tes listes de mails

Dim List_To As String, List_Cop As String, rng As Range, t, tt
'  UF_Attente.Show vbModeless
'ici je repère la dernière ligne vide pour la Collection des données
'ci- dessous début des lignes modifiées
With Worksheets("Mail")
        Set rng = .Range(.Cells(2, "N"), .Cells(Rows.Count, "N").End(3))
        If rng.Rows.Count > 2 Then
        t = Application.Transpose(rng.Value): List_To = Join(t, ";")
        tt = Application.Transpose(rng.Offset(, 1)): List_Cop = Join(tt, ";")
   'pour tester le contenu des listes de mails
'///////////////////////////////////
'à supprimer une fois que le test est bon
   MsgBox List_To
   MsgBox List_Cop
'///////////////////////////////////
        Else
        MsgBox "Attention: pas de destinataire!!!!"
        Exit Sub
        End If
End With
'fin des lignes modifiées
'    Set OutApp = CreateObject("Outlook.Application")

 

[castor30]

Bonjour Staple et merci de me répondre,
J'ai extrait la feuille concernée dans le classeur joint.

 

[Staple1600]

Bonsoir le fil, le forum

@castor30
Apparemment tu n'as pas testé le code précédent
(en tout cas, j'en vois pas trace)
Ça donne pas vraiment envie de s'impliquer davantage, non?

Un test

Sub a()
MsgBox ActiveSheet.Shapes("CorpsMessage").TextFrame.Characters.Text
End Sub

qui invite à utiliser Ce lien n'existe plus plutôt que Body seul.

 

[castor30]

Re,
Désolé mais je ne sais pas ou corriger.
J'ai cru comprendre qu'il prend les en-têtes de colonne Cc et Cci ça risque de poser problème si je ne me trompe pas bien sur.
Je te remercie.
édite : précision

 

[Staple1600]

Re

???
Il suffit de lire les commentaire en vert, non?
Et de remplacer la partie originale correspondante par ma proposition.

NB: Relire mon précédent message, je l'ai édité et ajouté des infos.

 

[castor30]

 

[Staple1600]

Re,

Je parlais de la macro du message#2
(avec des commentaires en vert qui permettent de comprendre quelle partie remplacée et où faire le remplacement)

Tu as cliqué sur le lien qui parle HTMLBody bien sur?

 

[Staple1600]

Re,

J'ai cru comprendre qu'il prend les en-têtes de colonne Cc et Cci ça risque de poser problème si je ne me trompe pas bien

Au lieu de croire comprendre, testes la macro tout simplement 🙄

 

[castor30]

Re,
Je suis trop néophyte, je ne comprend pas ce que je dois faire ou pas.

 

[Staple1600]

Re

Néophyte ou pas, il suffit de savoir lire!!
'ci- dessous début des lignes modifiées
...
'fin des lignes modifiées

Ce qui signifie que tu remplaces les lignes qui vont de
'ici je repère la dernière ligne vide pour la Collection des données
à la ligne juste avant

Set OutApp = CreateObject("Outlook.Application")

PS: Après trois ans d'inscription sur le forum, tu n'es plus néophyte.

 

[castor30]

Je reviendrais dans 30 ans, je laisse tomber
Merci

 

[Staple1600]

Re

Quand on se donne la peine comprendre ce qui écrit...
Ca va tout de suite plus vite, non 🙄

Spoiler: Voir macro modifiée

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, rng As Range, t, tt

    'ici je repère la dernière ligne vide pour la Collection des données
''ci- dessous début des lignes modifiées
With Worksheets("Mail")
        Set rng = .Range(.Cells(2, "N"), .Cells(Rows.Count, "N").End(3))
        If rng.Rows.Count > 2 Then
        t = Application.Transpose(rng.Value): List_To = Join(t, ";")
        tt = Application.Transpose(rng.Offset(, 1)): List_Cop = Join(tt, ";")
   'pour tester le contenu des listes de mails
'///////////////////////////////////
'à supprimer une fois que le test est bon
   MsgBox List_To
   MsgBox List_Cop
'///////////////////////////////////
        Else
        MsgBox "Attention: pas de destinataire!!!!"
        Exit Sub
        End If
End With
'fin des lignes modifiées
    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
End Sub

 

[castor30]

Avec mes excuses très sincères

 

[Staple1600]

Bonjour le fil, le forum

@castor30
Les excuses c'est pour le délai de ta réponse (plus de 2 mois)?

Sinon pourquoi ne pas joindre ton fichier directement sur le forum en cliquant sur Téléverser un fichier?

Si tu le postes, c'est que ta question n'est pas toujours résolue?