1 pièce(s) jointe(s)
afficher image avec .htmlbody en vba hors outlook
Bonjour,
je donne ma langue au chat...
j'ai utilise le code suivant :
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 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...
Pièce jointe 247418
Comment résoudre ces problèmes ?
Merci.
Guillaume.
une question de quote non
encore une histoire de " ' / "" \ "'", non ?
1 pièce(s) jointe(s)
sur COURRIER ca donne ca...
reste à ouvrir les images sur toutes les boites
Bonjour,
les images ne peuvent être vus sur toutes les boites emails (en plus, ca fait une croix rouge moche!)
sinon, tout est ok...
si vous avez une solution à me fournir, je suis preneur...
cette fois, ca dépasse mes capacités..
idem pour les input sur html j'ai du abandonner (ca ne fonctionne qu'avec Gmail)
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 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
|
Private Sub CommandButton101_Click()
totalcontact = 1
Do While (Sheets("contact").Range("A" & totalcontact) <> "")
totalcontact = totalcontact + 1
Loop
totalcontact = totalcontact - 1
' barr de progession
Application.ScreenUpdating = False
progression = 0
nbcontact = 1
Do
nbcontact = nbcontact + 1
labelprogession = Round(nbcontact / totalcontact * 100, 0)
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
'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
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
.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") = 587 '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
.From = Sheets("serveur").Range("B2").Value ' Mon Adresse email
.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
' on ecrit le mail
.HTMLBody = "<html><body>"
'.HTMLBody = .HTMLBody & "<form action=""mailto:guillaumepothier@hotmail.com"" method=""GET"">"
.HTMLBody = .HTMLBody & "<font face=""calibri"" size =""40"" color=""black""> hello <b>Bonjour ! " & prenom & " " & Nom & "</b></font>"
.HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
.HTMLBody = .HTMLBody & SAUTLIGNE & SAUTLIGNE
.HTMLBody = .HTMLBody & "<div align=""center""><table>"
.HTMLBody = .HTMLBody & "<tr>"
.HTMLBody = .HTMLBody & "<td><img src=""2-4.jpg""></td>" 'Ligne 1 - cols 1
.HTMLBody = .HTMLBody & "<td colspan=3><h3>Afin de mieux vous connaitre, de mesurer la satisfaction nos clients pour toujours mieux adapter la prestation de service et à évaluer l'importance accordée par le client à chacune de ces composantes.</h3></td>" 'Ligne 1 - cols 2à4
.HTMLBody = .HTMLBody & "</tr>"
.HTMLBody = .HTMLBody & "<tr>"
.HTMLBody = .HTMLBody & "<td><img src=""1-4.jpg""></td>" 'Ligne 1 - cols 1
.HTMLBody = .HTMLBody & "<td><h1>Participez à notre enquête de satisfaction !</h1></td>" 'Ligne 1 - cols 2
.HTMLBody = .HTMLBody & "<td colspan=2><img src=""3-4.jpg""></td>" ' Ligne 1 - cols 3 & 4
.HTMLBody = .HTMLBody & "</tr>"
.HTMLBody = .HTMLBody & "<td><img src=""4-4.jpg""></td>" 'Ligne 1 - cols 1
.HTMLBody = .HTMLBody & "<td colspan=3><h4><a href=""http://localhost/satisfaction.php"">Cliquez ici pour participer</a></h4></td>" 'Ligne 1 - cols 2à4
.HTMLBody = .HTMLBody & "</tr>"
.HTMLBody = .HTMLBody & "</table></div>"
.HTMLBody = .HTMLBody & "</form></body></html>"
'.Display
'.Save
.Send 'envoi automatique
End With
Loop Until (nbcontact = totalcontact)
End Sub |