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 |
Partager