Images ne s'affichent pas dans le mail

Le 19/12/2022 à 11:43

Bonjour à tous,

Je crée un mail via VBA dans lequel je fais apparaître une photo de cellules Excel + les photos liés à ma signatures Outlook, sauf que ces dernières ne s'affichent pas voir capture d'écran :

image

Je me demande si le problème ne viendrait pas du format HTML Body ?

Voici le code :

Sub Copier_CR()

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
'
' Valider_Copier Macro
    Range("A1:Y60").Select
    Selection.Copy
Application.WindowState = xlMinimized

Dim ObjOutlook As Object
Dim ObjMessage As Object

Set ObjMessage = OutApp.CreateItem(0)
Set wdDoc = ObjMessage.Getinspector.wordeditor

 ' Récupérer le nom du fichier de signature
 Dim NOM As String
    NOM = VBA.Interaction.Environ$("UserName")
    sPath = "C:\Users\" & NOM & "\AppData\Roaming\Microsoft\Signatures\"
  SigString = Dir(sPath & "*.htm")
  If SigString <> "" Then
      Signature = GetBoiler(sPath & SigString)
  Else
      Signature = ""
  End If

Call createJpg(ActiveSheet.Name, "A1:Y60", "PhotoTemp") 'ICI POUR MODIFIER LA ZONE DE CREATION DE L'IMAGE

With ObjMessage
.Close olSave

.To = Range("F1")
.Subject = Range("F1") & "Suivi de projet " & Range("S1") & " " & Range("F2") & " MàJ " & Range("Z1")

Texte = "<BODY style=font-size:11pt;font-family:Montserrat>Bonjour,<br><br>Ci-dessous le fichier de suivi du projet " & Range("F1") & " " & Range("S1") & " " & Range("F2") & ".<br><br>Merci de prendre connaissance de vos tâches.<br><br>"
Photo = "<img src='cid:PhotoTemp.jpg'>"
.HTMLbody = Texte & "<br>" & Photo & "<br></BODY>" & Signature
'.Attachments.Add ActiveWorkbook.FullName
.display
End With

Set ObjOutlook = Nothing
Application.CutCopyMode = False
Range("O27").Select
End Sub
Sub Save_PDF()

NomFichier = "\Suivi Projet_" & Range("F1").Value & "_" & Range("S1").Value & "_" & Range("F2").Value & "_" & Range("Z1").Value & ".pdf"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & NomFichier

End Sub

Function GetBoiler(ByVal sFile As String) As String
  Dim fso As Object
  Dim ts As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
  GetBoiler = ts.readall
  ts.Close
End Function

Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        For Each xShape In ActiveSheet.Shapes
            xShape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
   Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

D'avance merci de vos retours :D

Gabin,

7suivi-projet-forum.xlsm (213.12 Ko)
Le 20/12/2022 à 18:17

Bonsoir Gabin37

Pour ce qui est de la signature Outlook, il ne faut pas utiliser la fonction "GetBoiler" si justement tu as une image

Il suffit simplement d'afficher son mail avant traitement

With ObjMessage
  .Display
 ' Suite du code
End With

Pour l'image, c'est un peu plus compliquer, voir la réponse de Thev ICI
https://forum.excel-pratique.com/s/goto/1072261

A+

Rechercher des sujets similaires à "images affichent pas mail"