afficher image avec .htmlbody en vba hors outlook

**gpoth** · 22/02/2017, 20h04

Bonjour,

je donne ma langue au chat...
j'ai utilise le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
 Private Sub CommandButton101_Click()
 
 Dim Ws As Worksheet
 Dim ob As Object
 Dim Pieces, Adresse, ClasseurActif
 Dim OL As Object
 Dim OLmail As Object
 Dim Texte As String
 
 
 Sheets("contact").Select
 totalcontact = 1
 Do
 totalcontact = totalcontact + 1
 Loop Until (Range("A" & totalcontact) = "")
 
 
 
 Application.ScreenUpdating = False
 progression = 0
 
 nbcontact = 1
 Do
 nbcontact = nbcontact + 1
 labelprogession = nbcontact / totalcontact * 100
 progression = 200 * labelprogession / 100
 prenom = Sheets("contact").Range("A" & nbcontact).Value
 Nom = Sheets("contact").Range("B" & nbcontact).Value
 Adresse = Sheets("contact").Range("C" & nbcontact).Value
 
 
 Image_barre.Width = progression
 Label_barre.Caption = labelprogession & "%"
 DoEvents
 
 Application.ScreenUpdating = True
 
 
 
 'envoi du mail
 On Error Resume Next
Set OL = CreateObject("Outlook.Application") Set OLmail = OL.CreateItem(olMailItem) '0
 
 'enléve les messages d'alerte
 Application.DisplayAlerts = False
 'remet les messages d'alerte
 Application.DisplayAlerts = True
 'réactive le rafraichissement de l'écran
 Application.ScreenUpdating = True
 
 
 ' Adresse = "guil.pothier@gmail.com" 'pour exemple
 
 With OLmail
 .From = "guillaumepothier@hotmail.com"
 .To = Adresse
 .BodyFormat = olFormatHTML
 .Subject = "HMTL BODY du " & Date
 
 
 
 ' debut du message html
 Const SAUTLIGNE = "<br/>"
 
 
 
 .HTMLBody = "<body>"
 
 img1 = "1-4.jpg"
 img2 = "2-4.jpg"
 img3 = "3-4.jpg"
 img4 = "4-4.jpg"
 
 .Attachments.Add ThisWorkbook.Path & "\" & "1-4.jpg", olByValue, 0
 .Attachments.Add ThisWorkbook.Path & "\" & "2-4.jpg", olByValue, 0
 .Attachments.Add ThisWorkbook.Path & "\" & "3-4.jpg", olByValue, 0
 .Attachments.Add ThisWorkbook.Path & "\" & "4-4.jpg", olByValue, 0
 
 
 
 'Ecrit bonjour en gras, calibri, taille 40
 .HTMLBody = .HTMLBody & "<font face=""calibri"" size =""40"" color=""black""> hello <b>Bonjour ! " & prenom & " " & Nom & "</b></font>"
 'Saute deux lignes
 .HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
 'Ecrit le reste de l'entete
 
 .HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
 .HTMLBody = .HTMLBody & "<div align='center'><table>"
 .HTMLBody = .HTMLBody & "<tr>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b>test : <input type='text'>Ligne 1 - cols 1</input></b></td>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b><img src='" & img1 & "'>"
 .HTMLBody = .HTMLBody & "Ligne 1 - cols 2</b></td>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b><img src='" & img2 & "'>"
 .HTMLBody = .HTMLBody & "Ligne 1 - cols 3</b></td>"
 .HTMLBody = .HTMLBody & "</tr>"
 
 .HTMLBody = .HTMLBody & "<tr>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b><img src='" & img3 & "'>"
 .HTMLBody = .HTMLBody & "Ligne 2 - cols 1</b></td>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b><img src='" & img4 & "'>"
 .HTMLBody = .HTMLBody & "Ligne 2 - cols 2</b></td>"
 .HTMLBody = .HTMLBody & "<td valign='middle'><b>Ligne 2 - cols 3</b></td>"
 .HTMLBody = .HTMLBody & "</tr>"
 
 .HTMLBody = .HTMLBody & "</table></div>"
 
 .HTMLBody = .HTMLBody & "</body>"
 
 
 '.Display
 .Save
 .Send 'envoi automatique
 
 End With
 
 
 Loop Until (Range("A" & nbcontact) = "")
 
 
 End Sub

et ca marche..... uniquement sur Outlook.... mais pas sur Hotmail ou courrier ou gmail !!!!
Les images ne s'affichent pas... et le input text uniquement sur Gmail...

Nom : look.jpg
Affichages : 2267
Taille : 35,6 Ko

Nom : look.jpg
Affichages : 2267
Taille : 35,6 Ko

Comment résoudre ces problèmes ?
Merci.
Guillaume.

**gpoth** · 22/02/2017, 20h14

j'ai bien l'impression que je vais devoir m'orienter vers CDO, mais là suis perdu.
N'y-aurait-il pas un tuto ?

Merci.

Invité · 22/02/2017, 20h59

Bonsoir,
Je ne pense pas que le problème soit résolu par cdo, mais par la réduction du poids de l'image!

https://www.developpez.net/forums/d1...t/#post7968025

**gpoth** · 22/02/2017, 21h29

mes images ne pèsent que 4ko.

le problème , c'est l'affichage des images dans Gmail

Nom : look-gmail.jpg
Affichages : 2241
Taille : 44,4 Ko

l'input text est ok mais pas d'images.
sur Outlook, je vois les images mais pas l'input text

**gpoth** · 22/02/2017, 21h34

encore une histoire de " ' / "" \ "'", non ?

**gpoth** · 22/02/2017, 21h48

Nom : look-courrier.jpg
Affichages : 2241
Taille : 60,4 Ko

**patricktoulon** · 22/02/2017, 23h32

bonsoir

a ne pas confondre addattachment et AddRelatedBodyPart
pour le premier selon les niveau de compression des images l'application mail va interpréter c'est tres aléatoire
on les retrouvera dans le body ou pas
par contre !!!!!
pour le 2d c'est plus precis au niveau du mime en sortie et donc bien inclus dans le body avec les parametres que tu a donné dans le body

par contre a ma connaissance au niveau du codage HTML du body cela n'est pas géré en VBA POUR OUTLOOK
SEULEMENT CDO
avec outlook on peut seulement mettre des images mais pas organisées dans le document
et la selon encore une fois selon l'application que tu utilise et le serveur hébergeur tu pourra trouver tes images avant ou après le texte ou mélangé n'importe comment

voila voila

cdo mon ami

Je ne pense pas que le problème soit résolu par cdo, mais par la réduction du poids de l'image!

rohhrrrr!!!!! allons robert
j'ai déjà donné la fonction complète plusieurs fois

Invité · 23/02/2017, 07h05

Bonjour le forum et bonjour Patrick,

rohhrrrr!!!!! allons robert
j'ai déjà donné la fonction complète plusieurs fois

Oui mais quand je suis devant mon ordinateur je donne des solutions, mais là sur mon téléphone je donne des pistes!

Invité · 06/03/2017, 20h04

Il faut aller sur le site d'sfr et désactiver ipV6!

**gpoth** · 07/03/2017, 00h22

Merci.
Dès demain je teste ça.
Sinon avec Gmail, c'est impeccable... Je vais voir combien d'emails peut envoyer sfr. Autrement auriez vous un autre compte de messagerie à me conseiller ?
Merci.
Bonne soirée.

**patricktoulon** · 23/02/2017, 09h49

re
Bonjour Robert t'inquiet je plaisante
en tout et pour tout pour ce qu'il veut faire la méthode Outlook est a proscrire
le mime de Outlook est particulier

c'est l'adressage du src des images qui ne se fait pas correctement j'ai tout tenté a ce jour rien y fait
tandis qu'avec CDO l'adressage avec addrelatedbodypart se fait correctement
c'est pour ca que je m'étais tourner vers cet Object"CDO" depuis pas mal d'années déjà

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function SendMail()
    Set oEmail = CreateObject("CDO.Message")
    'configure message
    With oEmail.Configuration.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serveursmtp
        If serveursmtp = "smtp.gmail.com" Then    ' option  si on utilise gmail.com pour envoyer et non le serveur smtp de son  FAI
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "emetteur mail"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mot de passe"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587    'stmp server port changer le numero si necessaire
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        End If
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Update
    End With
    'preparation du message
    With oEmail
        .To = destinataire    ' mettre l'adresse ou les adresses du ou des destinataires si il y en a plusieurs les separer par un point virgule
        .From = emetteur    ' mettre l'adresse de l'emetteur
        .Subject = titre_du_mail    ' c'est plus qu'explicite pas la peine de commenter
        'maintenant le body html ahh!! en voila tout une histoire !!!
        code = "<h1> Bonjour voici quelques images<h1>"
        code = code & "</BR>"
        'code =code &  le reste de ton code html avec tes tables et images et tout i cointi  ici a la suite
        '********************************************************************************************
        '********************************************************************************************
        ' ATENTION!!!! si tu a des images dans des balises TD fait attention que ces balises TD aient été dimentionnées DANS LE CODE HTML sinon ta table sera déformée comme dans un document html d'ailleurs
        'exemple <td"style=""width:150px;height:150px;""><img style="" width:""100% ;height:100%;"" src=""blablablabla""></img> </td>"
        '*********************************************************************************************
        '*********************************************************************************************
        ' Maintenant on va préparer les addrelatedbodypart !!!!!!!!!!!!!!!!
        With CreateObject("htmlfile")
            .body.innerhtml = code
            Set mesimages = .getelementsbytagname("img")    ' on recupere tout les src des images
            For i = 0 To mesimages.Length - 1
                Set objBP = oEmail.AddRelatedBodyPart(mesimages(i).src, "balloon" & i, 1)    ' on les attaches en tant qu'element du body et non en atachement pieces jointes
                mesimages(i).src = "cid:balloon" & i & ".bmp"    ' on remplace le src du fichier par le lien du bodyrelatedpart
                objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<balloon" & i & ".bmp>"    ' on  valise l'attachement bodypart
                objBP.Fields.Update    ' on  valide pour le upload
            End If
        Next
        a = 0
        '************************************************************************************************
        oEmail.HTMLBody = .body.innerhtml    ' on met le code html transformé dans le body
    End With
    'on ajoute ici des piece jointe si on veut
    .AddAttachment "trucmachinchouette.txt" ' url du fichier sur ton disque dur
    .AddAttachment "trucmachinbidule.pdf" 'url du fichier sur ton disque dur
 
 
    'allez c'est parti on envoie !!!!!
    On Error GoTo gestioneerr
    oEmail.Send
    MsgBox "message envoyé"
    Exit Function
gestioneerr:
    MsgBox "Echec transmission:" & Err.Description
End Function
' il est tant d'aller boire un café
' 1 sucre SVP!!!!!

voila voila

**gpoth** · 23/02/2017, 10h59

bonjour à toi, je te remercie grandement pour ton aide si précieuse.
j'ai bien pris en compte tes remarques.
utiliser smtp.live ou smtp.gmail, je m'en doutais ne m'apporte que des problèmes.
et me donne un joli petit message d'erreur...

avec le port 25 et Hotmail ou Gmail :
Nom : erreur.jpg
Affichages : 2229
Taille : 24,0 Ko

Nom : erreur.jpg
Affichages : 2229
Taille : 24,0 Ko

avec le port 465 et Hotmail ou Gmail :
Nom : erreur1.jpg
Affichages : 2203
Taille : 24,4 Ko

peut-être, je n'en suis pas loin, peut-être pas, sinon j'ai SFR comme FAI, est-ce mieux ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
 
Private Sub CommandButton101_Click()
 
 
 
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 ' pour Gmail ou hotmail
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Sheets("serveur").Range("A2").Value
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Sheets("serveur").Range("B2").Value
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Sheets("serveur").Range("C2").Value
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25   'stmp server port changer le numero si necessaire
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False   'Use SSL for the connection (False or True)
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 
    .Update
End With
 
 
With iMsg
    Set .Configuration = iConf
 
' do
 
Sheets("contact").Select
totalcontact = 1
Do
totalcontact = totalcontact + 1
Loop Until (Range("A" & totalcontact) = "")
 
 
 
    Application.ScreenUpdating = False
    progression = 0
 
nbcontact = 1
Do
nbcontact = nbcontact + 1
labelprogession = nbcontact / totalcontact * 100
progression = 200 * labelprogession / 100
prenom = Sheets("contact").Range("A" & nbcontact).Value
Nom = Sheets("contact").Range("B" & nbcontact).Value
Adresse = Sheets("contact").Range("C" & nbcontact).Value
 
 
                Image_barre.Width = progression
                Label_barre.Caption = labelprogession & "%"
                DoEvents
 
    Application.ScreenUpdating = True
 
 
 
'envoi du mail
'On Error Resume Next
'    Set OL = CreateObject("Outlook.Application")
'    Set OLmail = OL.CreateItem(olMailItem) '0
 
 
 
        'enléve les messages d'alerte
        Application.DisplayAlerts = False
        'remet les messages d'alerte
        Application.DisplayAlerts = True
        'réactive le rafraichissement de l'écran
        Application.ScreenUpdating = True
 
 
 
    ' With OLmail
        .From = "guil.pothier@gmail.com" ' Adresse = "guil.pothier@gmail.com" 'pour exemple
        .To = Adresse
        .Subject = "HMTL BODY du " & Date
 
Const SAUTLIGNE = "<br/>"
 
 
    img1 = "1-4.jpg"
    img2 = "2-4.jpg"
    img3 = "3-4.jpg"
    img4 = "4-4.jpg"
 
 
        .AddRelatedBodyPart ThisWorkbook.Path & "\" & "1-4.jpg", img1, 1
        .AddRelatedBodyPart ThisWorkbook.Path & "\" & "2-4.jpg", img2, 1
        .AddRelatedBodyPart ThisWorkbook.Path & "\" & "3-4.jpg", img3, 1
        .AddRelatedBodyPart ThisWorkbook.Path & "\" & "4-4.jpg", img4, 1
 
 
 
'Ecrit bonjour en gras, calibri, taille 40
.HTMLBody = .HTMLBody & "<font face=""calibri"" size =""40"" color=""black""> hello <b>Bonjour ! " & prenom & " " & Nom & "</b></font>"
'Saute deux lignes
.HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
'Ecrit le reste de l'entete
 
.HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
.HTMLBody = .HTMLBody & "<div align=""center""><table>"
.HTMLBody = .HTMLBody & "<tr>"
.HTMLBody = .HTMLBody & "<td valign=""middle""><b>test : <input type=""text"">Ligne 1 - cols 1</input></b></td>"
.HTMLBody = .HTMLBody & "<td valign=""middle""><b><img src=""cid:1-4.jpg""> Ligne 1 - cols 2</b></td>"
.HTMLBody = .HTMLBody & "<td valign=""middle""><b><img src=""cid:2-4.jpg""> Ligne 1 - cols 3</b></td>"
.HTMLBody = .HTMLBody & "</tr>"
 
.HTMLBody = .HTMLBody & "<tr>"
.HTMLBody = .HTMLBody & "<td valign=""middle""><img src=""cid:3-4.jpg""> Ligne 2 - cols 1</td>"
.HTMLBody = .HTMLBody & "<td valign=""middle""><img src=""cid:4-4.jpg""> Ligne 2 - cols 2</td>"
.HTMLBody = .HTMLBody & "<td valign=""middle"">Ligne 2 - cols 3></td>"
.HTMLBody = .HTMLBody & "</tr>"
 
.HTMLBody = .HTMLBody & "</table></div>"
.HTMLBody = .HTMLBody & "</body>"
 
 
 
        '.Display
        '.Save
        .Send 'envoi automatique
 
 
 
Loop Until (Range("A" & nbcontact) = "")
 
End With
 
 
End Sub

du coup, je n'ai pas pu vérifier l'affichage des images...
je vous remercie de vos conseils éclairés

Guillaume.

**gpoth** · 23/02/2017, 12h22

Yesssssssssssssssss !!!!!!!!!!!!!! it works ! it mail !

il me reste à résoudre le problème des input type dans le contenu de l'email.
ca fonctionne avec Gmail mais pas Outlook bien sûr !

avez vous une idée ?

pensez vous que l'on puisse intégrer du javascript en plus ?

c'est dommage, j'aimerais aimé pouvoir joindre un form vba directement dans le corps de l'email, cela aurait été plus simple....

Merci de votre aide.
Guillaume.

Invité · 07/03/2017, 07h30

Bonjour,
De plus en plus les hébergeur utilise ipV6 pour améliorer la sécurité. Mais il est possible dans la plupart des cas de le désactiver!

Le quotas de mail est définit par sa charte! Certains comme orange permet même l'utilisation du port 25 sur la box de du contractant!

Il existe de serveur mail gratuits qui permettent d'utiliser les services d'un hébergeur tout en autorisant sa propre adresse mail (rd@dysorthographie.eu)!

http://mobile.clubic.com/telecharger...ailserver.html

Yahoo propose la virtualisation de adresses mails! Et de mémoire il utilise le port 25 mais depuis une attaque ressente je ne parierais pas!

**gpoth** · 07/03/2017, 10h47

bonjour, j'ai trop abusé du gmail on dirait, il ont fermé mon compte

à suivre... plus rien de gratuit maintenant, dommage...

Invité · 23/02/2017, 12h02

Bonjour,
en identifiant approuvé il faut fournir login pasword et sll true/false

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
With ConfigIf Identify = True Then
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True 'Use SSL for the connection (False or True)
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = User
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = PassWord
End If
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Port
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Serveur
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Delay
    .Update
  EndWith

et remplir le mail de l'expéditeur pour authentification!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
With msg    Set .Configuration = Conf
    .To = Dest
    .cc = DestEnCopy
    .FROM = Expediteur
    .Subject = Objet 
      .HTMLBody = Body

**Oliv-** · 23/02/2017, 12h34

Bonjour,

Avec un .display avant .send cela doit fonctionner.
assure toi que ton HTML soit correct à l'aide d'un éditeur HTML EN LIGNE
par exemple : http://htmleditor.in/index.html

Tu peux aussi pour créer un EMAIL EN HTML utiliser les fonctions WORDEDITOR et directement faire un copier coller de EXCEL vers ton Email

--> https://www.developpez.net/forums/d1...email-outlook/

Invité · 07/03/2017, 13h41

je ne pense pas qu'il on clôturé ton compte! ils ont estimé que tu étais victime d'un spammeur et il l'ont verrouillé pendant un lapes de temps!

ils te considère comme victime! mais il t'ont certainement envoyé un mais pour te demander si tu avais confiance en l'émetteur!

**gpoth** · 07/03/2017, 22h13

Bonsoir,
En ce qui concerne Gmail je leur ai écrit ce matin. Pour l'instant mon compte reste bloqué... Un peu trop beau pour être vrai... Tant pis, j'ai continué ma boucle avec mon sfr piano piano (1 e-mail toute les 5 secondes) pour ne pas les choquer ! Comme ça je peux en envoyer 100 sans blocage...
En revanche, je me rend compte que Orange et wanadoo sont pas si mauvais que ça puisqu'ils détectent automatiquement que c'est du 'spam'...
Même si je connais mes destinataires !

Avez-vous une solution à me proposer pour contrer les anti-spam (en dur bien évidemment !)

Merci les gars (et les filles) pour vos conseils.

Guillaume.