Code envoi mail

castor30

XLDnaute Occasionnel
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.
VB:
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
 

Pièces jointes

  • Classeur mail.xls
    95 KB · Affichages: 23
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum

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

En attendant un éventuel fichier exemple, je te propose cette autre façon (sans boucle) de créer tes listes de mails
VB:
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")
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
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
VB:
Sub a()
MsgBox ActiveSheet.Shapes("CorpsMessage").TextFrame.Characters.Text
End Sub
qui invite à utiliser Ce lien n'existe plus plutôt que Body seul.
 
Dernière édition:

castor30

XLDnaute Occasionnel
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
 
Dernière édition:

castor30

XLDnaute Occasionnel
0k7f.jpg
 

Staple1600

XLDnaute Barbatruc
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.
 

Staple1600

XLDnaute Barbatruc
Re

Quand on se donne la peine comprendre ce qui écrit...
Ca va tout de suite plus vite, non :rolleyes:
VB:
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
 

Statistiques des forums

Discussions
311 730
Messages
2 081 981
Membres
101 855
dernier inscrit
alexis345