Microsoft 365 Inserer copie d'ecran ou plage de cellules dans mail

[romubzh35]

Bonjour à tous,
j'utilise la macro ci dessous pour envoyer des mails récapitulatif mais il me manque une information, que je souhaite ajouter dans le corps du mail.
Soit insérer en tant que copie d'écran soit en tant que plage de données.
pourriez vous m'indiquer la marche à suivre svp

Sub EnvoiMail()

  Dim MonOutlook As Object
  Dim MonMessage As Object
  Dim corps As String

  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)
  MonMessage.To = ThisWorkbook.Sheets("Plan de convergence des stocks").Range("Q4").Value
  MonMessage.Subject = "Convergence des stocks : Mail automatique"
 corps = "<P>Bonjour , ci dessous les valeurs en date du " & UserForm1.TextBox19.Value & " provenant du fichier de convergence des stocks à " & UserForm1.TextBox21.Value & " : </P>"
 corps = corps & "<UL>"
 corps = corps & "  <LI>TRANSIT : </LI>"
 corps = corps & "  <UL>"
 corps = corps & "    <LI>" & UserForm1.TextBox1.Value & " K€ soit " & UserForm1.TextBox6.Value & " "
 corps = corps & "jour(s)</LI></UL>"
 corps = corps & "  <LI>RAW MATERIALS : </LI>"
 corps = corps & "  <UL>"
 corps = corps & "    <LI>" & UserForm1.TextBox2.Value & " K€ soit " & UserForm1.TextBox7.Value & " "
 corps = corps & "jour(s)</LI></UL>"
 corps = corps & "  <LI>WIP :</LI>"
 corps = corps & "  <UL>"
 corps = corps & "    <LI>" & UserForm1.TextBox3.Value & " K€ soit " & UserForm1.TextBox8.Value & " "
 corps = corps & "jour(s)</LI></UL>"
 corps = corps & "  <LI>FG : </LI>"
 corps = corps & "  <UL>"
 corps = corps & "    <LI>" & UserForm1.TextBox4.Value & " K€ soit " & UserForm1.TextBox9.Value & " "
 corps = corps & "jour(s)</LI></UL>"
 corps = corps & "  <LI>TOTAL : </LI>"
 corps = corps & "  <UL>"
 corps = corps & "    <LI>" & UserForm1.TextBox5.Value & " K€ soit " & UserForm1.TextBox10.Value & " "
 corps = corps & "  jour(s)</LI></UL></UL>"
 corps = corps & "<OL>"
 

 corps = corps & "  <LI>LISTING DES REFS AVEC MOINS DE 2 JOURS DE STOCKS :&nbsp;</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox32.Value & " : " & UserForm1.TextBox42.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox33.Value & " : " & UserForm1.TextBox43.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox34.Value & " : " & UserForm1.TextBox44.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox35.Value & " : " & UserForm1.TextBox45.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox36.Value & " : " & UserForm1.TextBox46.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox37.Value & " : " & UserForm1.TextBox47.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox38.Value & " : " & UserForm1.TextBox48.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox39.Value & " : " & UserForm1.TextBox49.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox40.Value & " : " & UserForm1.TextBox50.Value & " jour(s)</LI>"
 corps = corps & "  <LI>" & UserForm1.TextBox41.Value & " : " & UserForm1.TextBox51.Value & " jour(s)</LI></OL>"
 corps = corps & "<P>Ce message a été envoyé par l'utilisateur " & UserForm1.TextBox16.Value & ", Bonne "
 corps = corps & "journée.</P>"
MonMessage.HtmlBody = corps



  'MonMessage.send
    MonMessage.display
    
  Set MonOutlook = Nothing
End Sub

 

[kiki29]

Salut, va fouiller sur le site de Ron de Bruin : Mail from Excel with Outlook (Windows)

 

[romubzh35]

Salut, va fouiller sur le site de Ron de Bruin : Mail from Excel with Outlook (Windows)

Bonjour

ub Mail_small_Text_And_JPG_Range_Outlook()
'Ron de Bruin, 12-03-2022
'This macro use the function named : CopyRangeToJPG
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Dear Customer" & "<br><br>" & _
"Below you find a picture of your data." & "<br>" & _
"If you need more information let me know." & "<br><br>" & _
"Regards Ron<br>"

'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("Sheet1", "A1:H50")

If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If

On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=750 height=700></html>"
.Display 'or use .Send
End With
On Error GoTo 0

Kill MakeJPG

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub



Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
'Ron de Bruin, 25-10-2019
Dim PictureRange As Range

With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)

If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If

PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With

CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function

tout fonctionne très bien , par contre si je souhaite ajouter une copie d'ecran d'un autre onglet quelqu'un peut m'aider ?
j'ai copié le code dans le woorkbook de l'onglet concerné et ensuite je pensais rajouter la partie fonction dans le second onglet concerné

 

[patricktoulon]

re
bonjour
il en fait tout un toin toin ce ron de bruin pour 2 capture de plage dans un maoil outlook
allez la version patrick

Option Explicit
Sub Mail_small_Text_And_JPG_Range_Outlook()
'patricktoulon 26/02/2023
    
    Dim OutApp As Object, OutMail As Object, strbody$
    
    With Application
        '.EnableEvents = False'if not necéssary because  I dont activate a sheets Patrick
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Dear Customer" & "<br><br>" & _
              "Below you find a picture of your data." & "<br>" & _
              "If you need more information let me know." & "<br><br>" & _
              "Regards Pat<br> this is the first picture for you<br><br>"

    'Create JPG file of the range
    'Only enter the the range (object with prefixe (parent)
    'you can use the firstname of sheet or the name ther  then index
    'ex:Feuil1.[A1:H10]
    'ex2:sheets("Feuil1").[A1:H10]
    'ex3:sheets(1).[A1:H10]
    Dim Photo(1 To 2)
    Photo(1) = MakeRangeJPG(Feuil1.[A1:H10], "Photo1")
    Photo(2) = MakeRangeJPG(Feuil2.[d3:H11], "Photo2")
    'etc..etc...


    With OutMail
        .To = "trucmuche@youmémél.fr"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        
        .Attachments.Add Photo(1), 1, 0
        .Attachments.Add Photo(2), 1, 0

        'Note: Change the width and height as needed
        strbody = "<p>" & strbody & "</p><img src=""cid:Photo1.jpg"" >"

        strbody = strbody & "<br><br> this is a second picture for you" & "<br></p><img src=""cid:Photo2.jpg"" >"

        strbody = strbody & "<br>I hope you like it<br>soon :)"

        .HTMLBody = "<html>" & strbody & "</html>"
        .Display    'or use .Send
    End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = True 'if not necessary because  I dont activate a sheets patrick
        .ScreenUpdating = True
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub



Function MakeRangeJPG(Rng As Range, Lname As String) As String
   'simply Function copie range to fich picture By patricktoulon
   Dim chemin$
    Rng.CopyPicture
    chemin = Environ$("temp") & Application.PathSeparator & Lname & ".jpg"
    With Rng.Parent.ChartObjects.Add(0, 0, Rng.Width, Rng.Height)
        .Activate
        Do While .Chart.Pictures.Count = 0
            .Chart.Paste
        Loop
        .Chart.Export chemin, "JPG"
        .Delete
    End With
    MakeRangeJPG = chemin
End Function

 

[romubzh35]

merci bcp