Bonjour à tous
 
je m'entraine depuis un moment à ecrire tout seul mes codes VBA pour excel.
mais je suis un peu coincé sur un sujet.
 
j'ai des lignes de code, qui me permette d'envoyer un mail avec plusieurs fichiers joint.
 
cependant je voudrais copier plusieurs cellules d'un onglet excelt et l'ajouter dans le corps de mail en tant qu'image.
 
Pourriez-vous m'aider à ajouter les lignes de code qui me manqué pour avoir mon image dans le corps de mail.
 
MErci d'avance.
 
1ere macro : creation des fichier à joinder en fonction de plusieurs parametres
Public Sub DIFFUSER_Vehicule2()
Dim Chemin As String
Dim Nom_Fichier_g As String
Dim Nom_Fichier_br As String
Dim Nom_Fichier_cs As String
Dim Nom_Fichier_ouv As String
Dim Nom_Fichier_lup As String
 
Dim I As Integer
For I = 12 To Worksheets.Count
Worksheets(I).Visible = True
Next
 
Chemin = Worksheets("ACCUEIL" ).Cells(241, 15).Value
'definir le nom des fichier pdf
Nom_Fichier_g = Chemin & "\" & "Suivi indic CER" & "_" & Worksheets("TOLERIE" ).Cells(66, 4).Value & "_" & Worksheets("ACCUEIL" ).Cells(16, 11).Value & "_" & Worksheets("ACCUEIL" ).Cells(2, 5) & "_" & "S" & Worksheets("ACCUEIL" ).Cells(2, 2).Value & "_" & "Global"
Nom_Fichier_br = Chemin & "\" & "Suivi indic CER" & "_" & Worksheets("TOLERIE" ).Cells(66, 4).Value & "_" & Worksheets("ACCUEIL" ).Cells(16, 11).Value & "_" & Worksheets("ACCUEIL" ).Cells(2, 5) & "_" & "S" & Worksheets("ACCUEIL" ).Cells(2, 2).Value & "_" & "BR"
Nom_Fichier_cs = Chemin & "\" & "Suivi indic CER" & "_" & Worksheets("TOLERIE" ).Cells(66, 4).Value & "_" & Worksheets("ACCUEIL" ).Cells(16, 11).Value & "_" & Worksheets("ACCUEIL" ).Cells(2, 5) & "_" & "S" & Worksheets("ACCUEIL" ).Cells(2, 2).Value & "_" & "CDC_P1CS"
Nom_Fichier_ouv = Chemin & "\" & "Suivi indic CER" & "_" & Worksheets("TOLERIE" ).Cells(66, 4).Value & "_" & Worksheets("ACCUEIL" ).Cells(16, 11).Value & "_" & Worksheets("ACCUEIL" ).Cells(2, 5) & "_" & "S" & Worksheets("ACCUEIL" ).Cells(2, 2).Value & "_" & "OUV_FERR"
Nom_Fichier_lup = Chemin & "\" & "LUP CER" & "_" & Worksheets("ACCUEIL" ).Cells(16, 11).Value & "_" & Worksheets("ACCUEIL" ).Cells(2, 5) & "_" & "S" & Worksheets("ACCUEIL" ).Cells(2, 2).Value
 
'création fichier suivi global
 
    Worksheets("TOLERIE" ).PageSetup.PrintArea = "$A$59:$BQ$104"
    Worksheets("TdB GLOBAL" ).PageSetup.PrintArea = "$O$1:$z$72"
    Worksheets(Worksheets("TOLERIE" ).Cells(8, 4).Value).PageSetup.PrintArea = "$CD$134:$CX$237"
    Sheets(Array("TOLERIE", Worksheets("TOLERIE" ).Cells(8, 4).Value, "TdB GLOBAL" )).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Nom_Fichier_g & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
'création fichier suivi cs
 
    Worksheets("TdB périmètre P1CS" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre CdCaisse" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre LFR" ).PageSetup.PrintArea = "$O$1:$X$64"
    Sheets(Array("TdB périmètre P1CS", "TdB périmètre CdCaisse", "TdB périmètre LFR" )).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Nom_Fichier_cs & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
'création fichier suivi ouv
 
    Worksheets("TdB périmètre Hayon TP" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre CaissonPL" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre Sertissage" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre Ferrage" ).PageSetup.PrintArea = "$O$1:$X$64"
    Sheets(Array("TdB périmètre Hayon TP", "TdB périmètre CaissonPL", "TdB périmètre Sertissage", "TdB périmètre Ferrage" )).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Nom_Fichier_ouv & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
'création fichier suivi br
 
    Worksheets("TdB périmètre PrepaBR" ).PageSetup.PrintArea = "$O$1:$X$64"
    Worksheets("TdB périmètre P1BR" ).PageSetup.PrintArea = "$O$1:$X$64"
    Sheets(Array("TdB périmètre PrepaBR", "TdB périmètre P1BR" )).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Nom_Fichier_br & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
Worksheets("ACCUEIL" ).Select
 
'création fichier lup
 
    Worksheets("LUP CER" ).Select
    Worksheets("LUP CER" ).Range("$A$4:$Q$3303" ).AutoFilter Field:=15, Criteria1:="N"
    Worksheets("LUP CER" ).Cells(1, 17).EntireColumn.Hidden = False
    Worksheets("LUP CER" ).Cells(1, 16).EntireColumn.Hidden = False
    Worksheets("LUP CER" ).Range("$A$4:$Q$3303" ).AutoFilter Field:=17, Criteria1:=Cells(1, 17).Value
     
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Nom_Fichier_lup & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
         
'difition des paramètres du mail
 
    Dim subject As String
    Dim Body As String
    Dim listeMails As String
    Dim listebis As String
    Dim Plage As Range, R As Range
    Dim Plagecc As Range, T As Range
 
    ' créer un nouvel item mail
 
 'Collecte les cellules contenant une croix en colonne E
    Set Plage = Worksheets("ACCUEIL" ).Range("L44:L130" ).SpecialCells(xlCellTypeConstants, 2)
    'Pour chaque cellule collectée
    For Each R In Plage
        'On récupère l'adresse mail en colonne précédente(D)
        listeMails = listeMails & IIf(Len(listeMails) > 0, ";", "" ) & R.Offset(0, -1).Text
    Next R
 
'Collecte les cellules contenant une croix en colonne E
    Set Plagecc = Worksheets("ACCUEIL" ).Range("M44:M130" ).SpecialCells(xlCellTypeConstants, 2)
    'Pour chaque cellule collectée
    For Each T In Plagecc
        'On récupère l'adresse mail en colonne précédente(D)
        listebis = listebis & IIf(Len(listebis) > 0, ";", "" ) & T.Offset(0, -2).Text
    Next T
 
subject = Worksheets("ACCUEIL" ).Cells(218, 17).Value
Body = Worksheets("ACCUEIL" ).Cells(220, 15).Value
 
'envoi du mail en appelant un autre macro
 
Call ENVOYER_MAIL(listeMails, listebis, subject, Body, Worksheets("ACCUEIL" ).Cells(241, 15).Value)
 
Worksheets("LUP CER" ).Range("$A$4:$Q$3303" ).AutoFilter Field:=15, Criteria1:=Array("N", "O", "" ), Operator:=xlFilterValues
Worksheets("LUP CER" ).Range("$A$4:$Q$3303" ).AutoFilter Field:=17, Criteria1:=Array(Cells(1, 17).Value, Cells(1, 16).Value, "" ), Operator:=xlFilterValues
Worksheets("LUP CER" ).Cells(1, 17).EntireColumn.Hidden = True
Worksheets("LUP CER" ).Cells(1, 16).EntireColumn.Hidden = True
     
For I = 12 To Worksheets.Count
Worksheets(I).Visible = False
Next
 
Worksheets("ACCUEIL" ).Select
 
End Sub
 
2eme macro : envoi du mail avec les pieces jointes
Public Sub ENVOYER_MAIL( _
    listeMails As String, _
    listebis As String, _
    subject As String, _
    Body As String, _
    Optional Attach As Variant)
     
 ' --------------------------
    Dim I As Integer
    Dim ObjOutLook As New Outlook.Application
    Dim oEmail
    'Dim ObjOutlook As New Outlook.Application
    'Dim oBjMail
     
    Dim Fichier As String
 
    ' créer un nouvel item mail
 
    Set ObjOutLook = New Outlook.Application
    Set oEmail = ObjOutLook.CreateItem(olMailItem)
 
    ' les paramètres
 
 With oEmail
    .To = listeMails
    .Cc = listebis
    .subject = subject
    .Body = Body
 
    If Not IsMissing(Attach) Then
 
    If TypeName(Attach) = "String" Then
 
    Fichier = Dir(Attach & "\*.*" )
    Attach = Attach & "\"
    Do While Fichier <> ""
 
    oEmail.Attachments.Add Attach & Fichier
 
    Fichier = Dir()
    Loop
 
    Else
 
        For I = 0 To UBound(Attach) - 1
        .Attachments.Add Attach(I)
 
        Next
 
        End If
 
    End If
 
    ' envoie le message
    .Send
 
 End With
 
    ' détruit les références aux objets
    Set oEmail = Nothing
 
    Set appOutLook = Nothing
 
End Sub