Envoie de mails CDO

**Yersin** · 25/08/2011, 16h20

Bonjour à tous,

Je tente d’envoyer des mails à partir d’Excel par une procédure CDO avec le bout de code suivant (récupéré et adapté à partir du forum).

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
Public Const Expediteur = "<toto@taf.fr>"
Public Const MAIL_SENDUSING = 2
Public Const MAIL_AUTHENTICATE = 1
Public Const MAIL_CPT_SENDUSR = "Login"
Public Const MAIL_CPT_SENDPASS = "Motdepasse"
Public Const MAIL_SMTP_SERVER = "<serveur smtp>"
Public Const MAIL_SMTP_SERVERPORT = 587
 
Sub CDO_Snd(Destinataire As String, Titre As String, Corps As String)
On Error GoTo Sortie_Erreur
    Dim i As Long
    Dim objEmail As Object
 
    Set objEmail = CreateObject("CDO.Message") 'Crée un objet mail
 
    objEmail.From = Expediteur
    objEmail.To = Destinataire
    objEmail.Subject = Titre
    objEmail.TextBody = Corps
 
    With objEmail.Configuration.Fields
        .Item(CdoConfiguration.cdoSendUsingMethod) = MAIL_SENDUSING
        .Item(CdoConfiguration.cdoSMTPAuthenticate) = MAIL_AUTHENTICATE
        .Item(CdoConfiguration.cdoSendUserName) = MAIL_CPT_SENDUSR
        .Item(CdoConfiguration.cdoSendPassword) = MAIL_CPT_SENDPASS
        .Item(CdoConfiguration.cdoSMTPServer) = MAIL_SMTP_SERVER
        .Item(CdoConfiguration.cdoSMTPServerPort) = MAIL_SMTP_SERVERPORT
        .Update
    End With
    objEmail.Send
Exit Sub
Sortie_Erreur:
    MsgBox Err.Description
End Sub

Toutefois, j’ai systématiquement le message d’erreur « Le transport a échoué dans sa connexion au serveur ».

Je pense que cela peut venir du fait que nous utilisons un serveur Exchange mais je ne sais pas comment contourner ce problème.

En vous remerciant par avance pour l’aide que vous pourrez m’apporter,

Yersin

**pc75** · 25/08/2011, 17h38

Bonjour,

Voila un bout de code qui fonctionne chez moi :

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
 
Set oMail = CreateObject("CDO.Message")
Set oMailConfig = CreateObject ("CDO.Configuration")
 
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "XXXXX" ' Nom du serveur SMTP
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 ' Port utilisé
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' On utilise un service SMTP
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60 ' Timeout
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 ' 0 = aucune authentification ; 1 = authentification
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "USER" ' Utilisateur exchange si authentification = 1
oMailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "PWD" ' Mot de passe de l'utilisateur exchange si authentification = 1
oMailConfig.Fields.Update
Set oMail.Configuration = oMailConfig
oMail.Sender = "Expéditeur"
oMail.From = "FROM"
oMail.Fields.Update()
oMail.Subject = "Sujet")
oMail.To = "Destinataires")
oMail.CC = "Destinataires CC"
oMail.BCC = "Destinataires BCC"
Body = ""
Body = Body & "<html>"
Body = Body & "<body>"
Body = Body & "Le texte du message"
Body = Body & "</body>"
Body = Body & "</html>"
 
oMail.HTMLBody = Body
 
oMail.Send
Set oMailConfiguration = Nothing
Set oMailConfig = Nothing
Set oMail = Nothing

**Yersin** · 25/08/2011, 18h08

Bonjour pc75,

Je viens de testé ta solution mais j'ai toujours le même message d'erreur au moment du "Send".

OutLook est installlé sur l'ordi et arrive à envoyer des mails via Exchange.

N'y aurait-il pas un moyen de récupérer les infos dont dispose OutLook pour les réutiliser dans la macro?

Yersin

Envoie de mails CDO

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager