Insertion fichier PDF dans corps message outlook HTML

Version imprimable

:zoubi:
Bonjour
J'essaie depuis un moment d’insérer un fichier PDF dans le corps d'un message OUTLOOK(comme on le fait à la main dans OUTLOOK: Insérer+objet+créer à partir d'un fichier etc...)

J'ai repris du code trouvé sur Développez, et je l'ai arrangé à ma sauce : ajout valeur message avec balise HTML.
J'ai testé le code HTML sous IE et cela fonctionne.

Code:

<iframe src='D:\Fichier PP\Avis inspecteur du travail.pdf' width='500px' height='450px'></iframe>
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Dim MonApply As New Outlook.Application Dim MonMail As Outlook.MailItem Dim Message As String Set MonApply = Outlook.Application Set MonMail = MonApply.CreateItem(olMailItem) Message = "<iframe src='D:\Fichier PP\Avis inspecteur du travail.pdf' width='500px' height='450px'></iframe>" With MonMail .Subject = "Test insertion dans corps Aperçu pdf" '.Body = ThisWorkbook.FullName .HTMLBody = Message .Display End With
Ma question est la suivante : pourquoi, lorsque je lance cette macro, je n'ai pas le résultat escompté ?
Y a-t-il quelqu'un qui pourrait m'aider ?

A+:zoubi:

02/06/2015, 11h02
joe.levrai

Bonjour,

as-tu essayé la méthode .Add de la propriété Attachement de l'objet MailItem ?
(voir l'aide :f1: à ce sujet)

EDIT : désolé j'ai lu en diagonal, tu souhaites vraiment que ça soit dans le corps et pas en PJ ?
02/06/2015, 11h06
CharleLéo

:zoubi:
Bonjour

Non, parce que je pense que cette méthode ne fait que mettre en PJ le fichier PDF. Je ne connais pas bien cette méthode, je vais fouiller.

A+

J'ai testé la méthode add de attachment de l'objet MailItem, le résultat est l'insertion du fichier PDF en PJ

Code:

1
2
3
4
5
6
7
8
9
10
11
Dim MonApply As New Outlook.Application
Dim MonMail As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
 
 Set MonApply = Outlook.Application
 Set MonMail = MonApply.CreateItem(olMailItem)
 
 Set myAttachments = MonMail.Attachments
 myAttachments.Add "D:\Fichier PP\Avis inspecteur du travail.pdf", _
 olByValue, 1, "Test"
 MonMail.Display

A+

03/06/2015, 08h20
CharleLéo
:roll:
Bonjour,

Pour contourner le problème, je pensais à utiliser l'objet commandbar de OUTLOOK :
En effet pour insérer manuellement un fichier PDF (ou tout autre chose),dans le corps d'un message OUTLOOK, la procédure est la suivante :
1. Nouveau message
2. Menu insertion
3. insérer un objet
4. créer à partir du fichier
5. parcourir => on sélectionne le fichier => et on valide
Le fichier PDF apparait dans le corps du message, juste avant la signature.

Peut on faire cela en VBA en utilisant :
ObjetMail.getInspector.commandBars.item("Insert").Controls("&objet...").execute ?

A+
03/06/2015, 22h22
patricktoulon

heu

bonjour
perso j'utilise CDO pour mes mails
mais de la même manière on traite le message en html

alors la chose a faire est simple
envoie toi un message avec Outlook sur une 2 ° boite mail
regarde le code html du message
tu saura quoi faire en vba après
je dis ca moi j'dis rien ;)

Code réalisé qui fonctionne peut être à améliorer

:)
bonjour,

J'ai suivi le conseil de patricktoulon

A la lecture du message en HTML, on voit :

Code:

src="cid:image003.png@01D0A04B.7858C7E0"

J'en déduit que c'est outlook qui génère image003.png, alors que dans ma manip j'inserer un objet créer à partir d'un fichier pdf sur mon disque. Donc le fichier pdf est transformé en PNG.
Je pense qu'il n'y a pas de solution de ce coté là.

Par contre, hier j'ai trouvé une solution (inspiré du forum), qui à ce moment là, me paraissait "bidouillage" :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub AvisToGif(NomFeuille)
Dim Image As Range, Image_Chart As ChartObject
Dim NomfichierImage As String
 
' Suivant l'onglet EXCEL à envoyer par mail nom de fichier différent
Select Case NomFeuille
    Case "avis icp"
        NomfichierImage = "Avis_icp"
    Case "avis medecin du travail"
        NomfichierImage = "avis_medecin_du_travail"
    Case "avis inspecteur du travail"
        NomfichierImage = "avis_inspecteur_du_travail"
    End Select
' image est la zone d'impression de l'onglet
Set Image = Sheets(NomFeuille).Range("zone_d_impression")
' copier image dans le presse papier
Image.CopyPicture xlScreen, xlBitmap
With Image
    ' déprotéger la feuille sinon erreur
    Sheets(NomFeuille).Unprotect ("xxxxx")
    ' creation d'un graphique
    Set Image_Chart = Worksheets(NomFeuille).ChartObjects.Add(.Left, .Top, .Width + 5, .Height + 5)
End With
' copier presse papier dans graphique
Image_Chart.Chart.Paste
' redimensionner le graphique à 75% de sa taille originale
Image_Chart.ShapeRange.ScaleWidth 0.75, msoFalse, msoScaleFromTopLeft
Image_Chart.ShapeRange.ScaleHeight 0.75, msoFalse, msoScaleFromBottomRight
' sauvegarde du graphique en tant que image GIF
Image_Chart.Chart.Export Filename:=ActiveWorkbook.Path & "\" & NomfichierImage, FilterName:="GIF"
' ne pas oublier de supprimer l'image dans l'onglet
Image_Chart.Delete
' reprotéger la feuille sinon erreur
Sheets(NomFeuille).Protect ("xxxxx")
' liberer les variables
Set Image_Chart = Nothing
Set Image = Nothing
End Sub

Voilà, donc ma feuille EXCEL est transformé en image, ici en .GIF pour des raison de résolution, car en JPEG, la lecture dans OUTLOOK, n'est pas sensationnelle.
Aprés l'appel de cette fonction, j'utilise le code suivant pour envoi par courriel OUTLOOK

Code:

1
2
3
4
5
AvisToGif "avis icp"
StrBody = "<HTML><body>Bonjour " & "<BR><BR>" & "Veuillez prendre connaissance de la présente convocation" & "<br><BR>" & _
             "<img src=cid:avis_icp>" & "<BR><BR>Cordialement</body>" & "</html>"
 
Send_Mail_CorpsOutlook pj, Destinataire, "", "", "Avis debut de travaux", True, False, StrBody

la variable PJ contient le fichier .GIF construit dans AvisToGif, Destinaire une liste de destinataire
le code pour Send_Mail_CorpsOutlook

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Function Send_Mail_CorpsOutlook(ByVal FileNameImage As String, StrTo As String, _
                              StrCC As String, StrBCC As String, StrSubject As String, _
                              Signature As Boolean, Send As Boolean, ByVal StrBody As String)
    Dim OutApp As Object
    Dim OutMail As Object
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        If Signature = True Then .Display
        .to = StrTo
        .CC = StrCC
        .BCC = StrBCC
        .Subject = StrSubject
        .Attachments.Add FileNameImage
        .HTMLBody = StrBody & "<br>" & .HTMLBody
 
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Voilà, dite moi si il ya des améliorations à faire, sinon j'utilise ce code et celà fonctionne.
Petit bémol, je n'ai pas encore traiter l'image de fond (on voit PAGE 1 au centre de l'image) issue de la feuille EXCEL transformée en image.

Peut être que OUTLOOK fait la même chose lorsque on insert un fichier (quel qu’il soit dans le corps du message)
A+

Bonjour
c'est quand même une belle approche

cependant je n'avais pas compris que le fichier pdf était une feuille ou une sélection transformée en pdf
pour ma part en cdo je construit une table html correspondant a la sélection ou la feuille

dans les contribution VBA tu trouvera ma contrib sur le sujet
il te reste plus qu'a intégrer la table html dans ton mail et plus besoins de pièce jointe
c'est bien non???;)

re
voila j'ai réuni 2 code que je me sert pour moi pour te faire un exemple
c'est pas parfait mais le résultat dans le message parle de lui même
tout d'abords ouvre un classeur vierge et met lui 2 modules
1 er module pour le mail en CDO
colle lui ca dedans
tu n'a plus qu'a changer les valeur de destinataire ,emetteur,serveur,debtexte,sujet et enfin plage

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub sending_mail_CDO()
debtexte = "Bonjour voici le tableau que vous m'avez demandé" & "<br>" & " Vous souhaitant bonne reception"
Set plage = Selection
serveur = "smtp.orange.fr"'chez moi c'est orange pour toi c'est peut être différent 
destinataire = "destinataire@hotmail.fr"
emetteur = "moi@live.com"
sujet = "essaie de mail "
paragraphe = grille_To_HTML(plage, True)
Dim iMsg As Object, iConf As Object, Flds As Object
 Set iMsg = CreateObject("cdo.message")
Set iConf = CreateObject("cdo.configuration")
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    'remplacez "smtp.nomserveur.fr" par le nom de serveur de votre FAI :
    'http://outlook.developpez.com/faq/index.php?page=Configuration#Paras_FAI
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serveur
    .Update
End With
With iMsg
    Set .Configuration = iConf
    .To = destinataire
    .From = emetteur
    .Subject = sujet
    .HTMLBody = debtexte & paragraphe
    ' .AddAttachment 'c:\mon dossier\monfichier.extention"
    .Send
End With
End Sub

ensuite dans le 2 eme module met lui mon code excel to html
j'ai laissé aussi la sub pour créer un fichier html ca peut servir

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
 
Sub ExCel_to_fichier_avec_style()
    Dim plage As Range, chemin As String
    Set plage = Selection
     chemin = "C:\Users\" & Environ("UserName") & "\Desktop\" & Replace(plage.Address, ":", "-") & " Avec  style " & ".html"
    createfichier3 chemin, grille_To_HTML(plage, True)
End Sub
Function récupere_codehtml_de_la_plage_avec_style()
    Dim plage As Range
    Set plage = Selection
    MsgBox grille_To_HTML(plage, True)
End Function
Public Function grille_To_HTML(plage, Optional LsTyLe As Boolean = False) As String
    Dim dicorange, codehtml, iedoc As Object, cel, coulnoborder, celhtml, matable, elem, ligne As Long
    Dim brTop, brLLeft, brBottom, brRight, SbrTop, SbrLLeft, SbrBottom, SbrRight
    Set dicorange = CreateObject("Scripting.Dictionary")
    Set iedoc = CreateObject("htmlfile")
    codehtml = "<html>" & vbCrLf & "<table>" & vbCrLf & "<tr" & " class= ligne1" & ">" & vbCrLf
    ligne = plage.Row
    coulnoborder = coul_XL_to_coul_HTMLX(15853019)
    For Each cel In plage.Cells
        If Not dicorange.exists(cel.MergeArea.Address) Then
            dicorange(cel.MergeArea.Address) = ""
            If cel.Row <> ligne Then ligne = cel.Row: codehtml = codehtml & vbCrLf & "</tr>" & vbCrLf & "<tr" & _
                                                               " class= ligne" & cel.Row & ">" & vbCrLf
            codehtml = codehtml & "<td" & " id= " & cel.MergeArea.Address & ">" & cel.Value & "</td>" & vbCrLf
        End If
    Next
    With iedoc
        .write codehtml
        Set celhtml = .getelementsbytagname("td")
        Set matable = .getelementsbytagname("table")(0)
        With matable: .cellpadding = 0: .cellspacing = 0:
       '.Style.bordercollapse = "collapse"
        .classname = Replace(Replace(plage.Address, ":", "-"), "$", "")
        End With
        For Each elem In celhtml
            elem.rowspan = Range(elem.ID).Rows.Count
            elem.colspan = Range(elem.ID).Columns.Count
            elem.Style.Width = Range(elem.ID).Width / (3 / 4)
            elem.Style.Height = Range(elem.ID).Height / (3 / 4)
            elem.Style.FontSize = Range(elem.ID).Font.Size * 1.3
            elem.Style.Border = 1 & " solid " & coulnoborder
            If Range(elem.ID).HorizontalAlignment <> 1 Then elem.Style.TextAlign = "center"
            If Range(elem.ID).VerticalAlignment = xlBottom Then elem.Style.verticalalign = "bottom"
            If LsTyLe = False Then
                matable.Style.Border = 1 & " solid " & "gray"    'coulnoborder
            Else
                elem.Style.Border = 0
                elem.Style.fontweight = IIf(Range(elem.ID).Font.Bold, "Bold", "normal")
                elem.Style.fontFamily = Range(elem.ID).Font.Name
                elem.Style.FontStyle = IIf(Range(elem.ID).Font.Italic = True, "italic", "normal")
                elem.Style.BackgroundColor = coul_XL_to_coul_HTMLX(Range(elem.ID).Interior.Color)
                elem.Style.Color = coul_XL_to_coul_HTMLX(Range(elem.ID).Font.Color)
                SbrTop = borders(Range(elem.ID).borders(xlEdgeTop)).lestyle
                SbrBottom = borders(Range(elem.ID).borders(xlEdgeBottom)).lestyle
                SbrRight = borders(Range(elem.ID).borders(xlEdgeRight)).lestyle
                SbrLLeft = borders(Range(elem.ID).borders(xlEdgeLeft)).lestyle
 
                brTop = borders(Range(elem.ID).borders(xlEdgeTop)).leWeights
                brBottom = borders(Range(elem.ID).borders(xlEdgeBottom)).leWeights
                brRight = borders(Range(elem.ID).borders(xlEdgeRight)).leWeights
                brLLeft = borders(Range(elem.ID).borders(xlEdgeLeft)).leWeights
 
                If Range(elem.ID).Row = plage.Row And Range(elem.ID).borders(xlEdgeTop).LineStyle <> xlNone Then elem.Style.BorderTop = brTop & " " & SbrTop & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).borders(xlEdgeTop).Color)
                If Range(elem.ID).Column = plage.Column And Range(elem.ID).borders(xlEdgeLeft).LineStyle <> xlNone Then elem.Style.Borderleft = brLLeft & " " & SbrLLeft & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).borders(xlEdgeLeft).Color)
                If Range(elem.ID).borders(xlEdgeBottom).LineStyle <> xlNone Then elem.Style.Borderbottom = brBottom & " " & SbrBottom & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).borders(xlEdgeBottom).Color)
                If Range(elem.ID).borders(xlEdgeRight).LineStyle <> xlNone Then elem.Style.Borderright = brRight & " " & SbrRight & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).borders(xlEdgeRight).Color)
 
 
   If Range(elem.ID).Row = plage.Row And Range(elem.ID).borders(xlEdgeTop).LineStyle = xlNone Then elem.Style.BorderTop = 1 & " solid" & " " & coulnoborder
                If Range(elem.ID).Column = plage.Column And Range(elem.ID).borders(xlEdgeLeft).LineStyle = xlNone Then elem.Style.Borderleft = 1 & " solid" & " " & coulnoborder
                If Range(elem.ID).borders(xlEdgeBottom).LineStyle = xlNone Then elem.Style.Borderbottom = 1 & " solid" & " " & coulnoborder
                If Range(elem.ID).borders(xlEdgeRight).LineStyle = xlNone Then elem.Style.Borderright = 1 & " solid" & " " & coulnoborder
 
 
   End If
        Next
        grille_To_HTML = .body.innerhtml
    End With
End Function
Function borders(Cote) As propert
borders.leWeights = Switch(Cote.Weight = 1, 1, Cote.Weight = 2, 1, Cote.Weight = -4138, 2, Cote.Weight = 4, 3)
borders.lestyle = IIf(Cote.LineStyle <> 1, "dashed", "solid")
'If Cote.LineStyle = xlDashDotDot Then borders.leWeights = 3 'xlDashDotDot
If Cote.LineStyle = xlDash And Cote.Weight = xlThick Then borders.leWeights = 2 ' xldash et epaisseur xlthick   'Tiret en pointillet
If Cote.LineStyle = xlDash And Cote.Weight = xlThin Then borders.leWeights = 2:: borders.lestyle = "dotted"     'point  en pointillet
End Function
 
Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    'If couleur = 16777215 Then couleur = vbWhite
    str0 = Right("000000" & Hex(couleur), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & str & ""
End Function
Public Sub createfichier3(chemin, texte)
    Dim intFic As Integer
    intFic = FreeFile
    Open chemin For Output As intFic
        Print #intFic, texte
    Close intFic
End Sub

voila ne m'en veux pas j'ai fait ca vite fait
si tu ne veux pas te servir de cdo tu peut toujours te servir de la fonction "grille_To_HTML" et l'intégrer dans le corps de ton message Outlook
;)

06/06/2015, 18h51
CharleLéo

:oops:
je viens d'essayer Grille_To_HTLM

A l'affichage, j'ai des problèmes de format, de plus, dans le corps du mail les données sont modifiables.

Merci de ta contribution, je vais utliser mon code

A+
06/06/2015, 20h33
patricktoulon

2 pièce(s) jointe(s)

re

re
que de sottises que tu dis
voici une capture d'écran de Outlook dans ma boite mail
Pièce jointe 179868

et voici une capture d'écran de la feuille utilisée
Pièce jointe 179869

vraiment que de sottises ;)
ou tu a vu que l'on pouvait modifier une cellule html a par dans le code source hein!!?????