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
| Sub test()
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
Const SSL = False
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay
Dim Serveur
Dim User
Dim PassWord
Dim Por
Dim Delay
Dim Expediteur
Dim Dest
Dim DestEnCopy
Dim DestEnCopyCaher
Dim Objet
Dim Body
Dim Pj
Serveur = "MyServeur"
User = "MyUser"
PassWord = "MyPassWord"
Port = 25
Delay = 10
Expediteur = "MyExpediteur@MyEbergeur.fr"
Dest = "MyDest@MyEbergeur.fr"
DestEnCopy = "MyDestEnCopy@MyEbergeur.fr"
DestEnCopyCaher = "MyDestEnCopyCaher@MyEbergeur.fr"
Objet = "Je te parle de:"
Body = "Je vous parle d’un temps que les moins de vingt ans ne peuvent pas connaître"
Pj = ""
MailEnvoi Serveur, cdoAnonymous, SSL, User, PassWord, Port, Delay, cdoDSNDefault, Expediteur, Dest, DestEnCopy, DestEnCopyCaher, Objet, Body, Pj
End Sub
'**************************************************************************************************************************************************************************************************************
Public Sub MailEnvoi(Serveur, Identify, SSL, User, PassWord, Port, Delay, cdoDSN, Expediteur, Dest, DestEnCopy, DestEnCopyCaher, Objet, Body, Pj)
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim splitPj
Dim IsplitPj
Dim schema
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") ' pour la configuration de l'envoi
Dim strHTML
Set Config = Conf.Fields
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
schema = "http://schemas.microsoft.com/cdo/configuration/" 'smtpusessl
With Config
If Identify <> 0 Then
.Item(schema & "smtpusessl") = SSL
.Item(schema & "smtpusetls") = 1
.Item(schema & "smtpauthenticate") = Identify
.Item(schema & "sendusername") = User
.Item(schema & "sendpassword") = PassWord
End If
.Item(schema & "smtpserverport") = Port
.Item(schema & "sendusing") = 2
.Item(schema & "smtpserver") = Serveur
.Item(schema & "smtpconnectiontimeout") = Delay
.Item(schema & "enablessl") = 1
.Update
End With
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
With msg
Set .Configuration = Conf
.To = Dest
.cc = DestEnCopy
.bcc = Expediteur & ";" & DestEnCopyCaher
.bcc = DestEnCopyCaher
.FROM = Expediteur
.Subject = Objet
.DSNOptions = cdoDSN
'
.htmlbody = Body '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
If Pj <> "" Then
splitPj = Split(Pj & ";", ";")
For IsplitPj = 0 To UBound(splitPj)
If Trim("" & splitPj(IsplitPj)) <> "" Then
.AddAttachment Trim("" & splitPj(IsplitPj))
End If
Next
End If
On Error Resume Next
.Send 'envoi du message
If Err <> 0 Then
MsgBox Err.Description
Else
MsgBox "Fin"
End If
End With
' reinitialisation des variables
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
End Sub |
Problème macro envoi mail automatique
Répondre avec citation
Envoyé par jpcheck
Partager