XL 2016 Mettre du texte dans un mail automatisé depuis Excel sans que la capture l'efface.

[Loc3007]

Bonjour,

J'ai crée un fichier de recensement, avec une macro qui fait une capture d'écran et qui l'envoi dans 2 mails distinct.
Mon souci, quand les mails sont créés, il efface le texte-:
(Bonjour,

Vous trouverez ci dessous les données...).

Si vous pouvez modifier ce fichier, j'en serais ravi.

En vous remerciant.

Cordialement

 

[fanch55]

Bonsoir

 

[Loc3007]

Bonjour,

Merci, pour cette réponse rapide et satisfaisante.🙂

Cordialement

 

[fanch55]

De rien,
Si vous voulez une version simplifiée et condensée :

Sub Envoi_Email()
    
    Mailto Join(WorksheetFunction.Transpose(Sheets("mails").[A3:A10]), ";")
 '   Mailto Join(WorksheetFunction.Transpose(Sheets("mails").[E2:E8]), ";")
    
End Sub
Sub Mailto(Dest, Optional CC = "")
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = Destinataires
        If CC <> "" Then .CC = CC
        .Subject = "Bilan des grévistes"
        .Display ' pour pouvoir exploiter le wordeditor
        Sig = .body ' Pour récupérer la signature éventuelle
        .body = ""
        With .GetInspector.WordEditor
            .Content.InsertBefore _
                "Bonjour, " & vbLf & _
                "Vous trouverez ci-dessous l'état récapitulatif des agents déclarés grévistes ce jour." & vbLf
            
            .Content.InsertParagraphAfter
             Sheets("Bilan grévistes").Range("A1:B61").CopyPicture
            .Paragraphs(4).Range.Paste
            
            .Content.InsertParagraphAfter
            .Content.InsertAfter vbLf & "Cordialement,"
            .Content.InsertAfter Sig
        End With
    End With
End Sub

 

[Loc3007]

Bonjour franch 55,

Merci, pour ces améliorations, j'ai encore un petit souci, avec le code ci-dessous, il génère 2 mails, concernant le 1er pas de soucis (il y a bien les destinataire entre A5 àA10 et les destinataires en copie de B5 à B10 de l'onglet mails), par contre pour le 2nd mail, il me mets en destinataire principale de la liste B de l'onglet mails, et non de la colonne E (de E5 à E10).
Avez-vous une solution ? aussi si vous pouvez ajouter le paver de signature comme dans votre dernière réponse ?

En vous remerciant, cordialement.

Sub Envoi_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim Destinataire1 As String ' <-- Ajout de la déclaration
Dim Destinataire2 As String
Dim Capture As Range

Destinataire1 = ""
For i = 2 To 10
Destinataire1 = Destinataire1 & Sheets("mails").Range("A" & i).Value & ";"
Next i
Destinataire1 = Left(Destinataire1, Len(Destinataire1) - 1)

'Définition des destinataires de la deuxième liste (en copie)
Destinataire2 = ""
For i = 2 To 10
Destinataire2 = Destinataire2 & Sheets("mails").Range("B" & i).Value & ";"
Next i
Destinataire2 = Left(Destinataire2, Len(Destinataire2) - 1)

'Création du texte de l'email
Dim Texte As String
Texte = "Bonjour," & vbCrLf & vbCrLf & "Vous trouverez ci-dessous l'état récapitulatif des agents déclarés grévistes ce jour. "

'Copie de la capture d'écran
Set Capture = Sheets("Bilan grévistes").Range("A1:B61")
Capture.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Création du brouillon de premier email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Destinataire1 ' Ajout des destinataires principaux
.CC = Destinataire2 ' Ajout des destinataires en copie
.Subject = "Bilan des grévistes"
.Body = Texte
.Display
Set wdDoc = .GetInspector.WordEditor
wdDoc.Content.InsertParagraphAfter
wdDoc.Content.InsertParagraphAfter
wdDoc.Paragraphs(3).Range.Paste
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter vbCrLf & "Cordialement,"
End With

Set OutMail = Nothing
Set OutMail = OutApp.CreateItem(0)
'Création du brouillon de deuxième email
With OutMail
.To = Destinataire2 ' Ajout des destinataires en copie
.Subject = "Bilan des grévistes"
.Body = Texte
.Display
Set wdDoc = .GetInspector.WordEditor
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter " "
wdDoc.Range(0, wdDoc.Characters.Count).InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter vbCrLf & "Cordialement,"
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[Loc3007]

Re bonjour,

Je viens de trouver, il manque que l'insertion du pavé de signature.

Sub Envoi_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim Destinataire1 As String
Dim Destinataire2 As String
Dim Destinataire3 As String
Dim Capture As Range

Destinataire1 = ""
For i = 5 To 10
Destinataire1 = Destinataire1 & Sheets("mails").Range("A" & i).Value & ";"
Next i
Destinataire1 = Left(Destinataire1, Len(Destinataire1) - 1)

Destinataire2 = ""
For i = 5 To 10
Destinataire2 = Destinataire2 & Sheets("mails").Range("B" & i).Value & ";"
Next i
Destinataire2 = Left(Destinataire2, Len(Destinataire2) - 1)

Destinataire3 = ""
For i = 5 To 10
Destinataire3 = Destinataire3 & Sheets("mails").Range("E" & i).Value & ";"
Next i
Destinataire3 = Left(Destinataire3, Len(Destinataire3) - 1)

Dim Texte As String
Texte = "Bonjour," & vbCrLf & vbCrLf & "Vous trouverez ci-dessous l'état récapitulatif des agents déclarés grévistes ce jour. "

Set Capture = Sheets("Bilan grévistes").Range("A1:B61")
Capture.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Destinataire1
.CC = Destinataire2
.Subject = "Bilan des grévistes"
.Body = Texte
.Display
Set wdDoc = .GetInspector.WordEditor
wdDoc.Content.InsertParagraphAfter
wdDoc.Content.InsertParagraphAfter
wdDoc.Paragraphs(3).Range.Paste
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter vbCrLf & "Cordialement,"
End With

Set OutMail = Nothing
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Destinataire3
.Subject = "Bilan des grévistes"
.Body = Texte
.Display
Set wdDoc = .GetInspector.WordEditor
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter " "
wdDoc.Range(0, wdDoc.Characters.Count).InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
wdDoc.Range(0, wdDoc.Characters.Count).InsertAfter vbCrLf & "Cordialement,"
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub


Merci

Cordialement

 

[fanch55]

Le code suivant fait ce que vous décrivez en dernier .
Cela n'a plus de lien avec le classeur que vous avez fourni ..

Sub Envoi_Email()
    
    Mailto Dest:=Join(WorksheetFunction.Transpose(Sheets("mails").[A5:A10]), ";"), _
             CC:=Join(WorksheetFunction.Transpose(Sheets("mails").[B5:B10]), ";")

   Mailto Dest:=Join(WorksheetFunction.Transpose(Sheets("mails").[E5:E10]), ";")
    
End Sub
Sub Mailto(Dest, Optional CC = "")
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = Destinataires
        If CC <> "" Then .CC = CC
        .Subject = "Bilan des grévistes"
        .Display ' pour pouvoir exploiter le wordeditor
        Sig = .body ' Pour récupérer la signature éventuelle
        .body = ""
        With .GetInspector.WordEditor
            .Content.InsertBefore _
                "Bonjour, " & vbLf & _
                "Vous trouverez ci-dessous l'état récapitulatif des agents déclarés grévistes ce jour." & vbLf
            
            .Content.InsertParagraphAfter
             Sheets("Bilan grévistes").Range("A1:B61").CopyPicture
            .Paragraphs(4).Range.Paste
            
            .Content.InsertParagraphAfter
            .Content.InsertAfter vbLf & "Cordialement,"
            .Content.InsertAfter Sig
        End With
    End With
End Sub

 

[Loc3007]

Bonjour,

Merci 👍.

Cordialement