Problème d'envoi de message SMTP depuis VBA

Version imprimable

Bonsoir à tous,

J'ai développé il y a quelques années un bout de code VBA permettant d'envoyer des emails depuis une base de données Access en utilisant le protocole SMTP et mon adresse Gmail.

Je l'ai utilisé à plusieurs reprises et tout a fonctionné parfaitement jusqu'à aujourd'hui. Je devais simplement réactiver périodiquement le paramètre "Autoriser les applications moins sécurisées" dans mon compte Gmail car ce paramètre est désactivé après un certain temps par Google...

Aujourd'hui, après avoir réactivé le paramètre ci-dessus, j'ai tenté d'envoyer un email groupé et le message d'erreur suivant s'affiche :

Citation:

Erreur -2147220973 Le transport a échoué dans sa connexion au serveur

Mon adresse de messagerie et le mot de passe correspondant n'ont pas été modifiés depuis mon dernier envoi.

Voici le contenu de ma procédure VBA :
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 'Déclaration des variables Dim objEmail As New CDO.message 'Composition du contenu du message objEmail.From = [Mon nom complet] objEmail.Bcc = [Destinataires en copie cachée] objEmail.Subject = [Sujet] objEmail.TextBody = [Corps du message] objEmail.AddAttachment [Chemin de la pièce jointe] 'Paramétrage de l’envoi du message With objEmail.Configuration.Fields .Item(CdoConfiguration.cdoSendUsingMethod) = 2 .Item(CdoConfiguration.cdoSMTPAuthenticate) = 1 .Item(CdoConfiguration.cdoSendUserName) = [Mon adresse gmail complète] .Item(CdoConfiguration.cdoSendPassword) = [Mot de passe de mon compte Gmail] .Item(CdoConfiguration.cdoSMTPServer) = “smtp.gmail.com” .Item(CdoConfiguration.cdoSMTPServerPort) = 465 .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "True" .Update End With 'Envoi du message objEmail.Send
Savez-vous comment résoudre ce problème ? Pour information, je ne peux malheureusement pas changer d'adresse de messagerie.

En vous remerciant pour votre aide, je vous souhaite une bonne soirée.
Cdt,

Philippe

08/12/2020, 21h23
Philippe1975

Tests complémentaires

Bonsoir à tous,

Quelques précisions complémentaires suite à des tests réalisés ce jour : J'ai tenté d'utiliser d'autres services de messagerie que Gmail (Hotmail, fournisseur d'accès Orange) et le problème est le même. Le transport vers le serveur échoue quel que soit le serveur. J'ai également utilisé un deuxième PC disponible à mon domicile et le problème est le même.

Savez-vous ce qui pourrait empêcher globalement l'envoi de message SMTP, alors que cela fonctionnait il y a quelques mois ? Y a-t-il un blocage au niveau du pare-feu ?

Pour info, ma Livebox a été remplacée entre-temps mais je doute que cela soit la cause du problème (?).

Merci d'avance pour votre aide
Cordialement,

Philippe

Bonjour,

Vous pouvez peut-être essayer avec ceci

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
Function SendEmail()
'This function sends the report to a list of recipients through the SMTP gateway (internet mail)
 
 
Dim oMail As Object
Dim oMailConfig As Object
Dim strMailT As String
 
Set oMail = CreateObject("CDO.Message")
Set oMailConfig = CreateObject("CDO.Configuration")
 
 
oMail.FROM = "moi.meme@societe.com"
oMail.to = "mon.collegue@societe.com"
oMail.CC = "unAutre.collegue@societe.com"
 
oMail.Subject = "EMEA Summary report"
 
strMailT = "This Email is sent by the VBA module of my MS Access database."
oMail.Textbody = strMailT
 
oMail.addattachment "C:\Temp\test.txt"
'instead of xxx, type here the name of the SMTP server at your company.
'I also used it at home with my private internet connection and I found the name of the SMTP server on the original letter sent to me by my
'telephone company when subscribed to a internet connection.
oMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxxxxx"
'oMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
oMail.Configuration.Fields.Update
 
 
oMail.send
 
Set oMailConfig = Nothing
Set oMail = Nothing
 
End Function

Bonne chance et tenez-nous au courant de vos succès.

09/12/2020, 15h17
Philippe1975

1 pièce(s) jointe(s)

Le transport a échoué pendant sa connexion avec le serveur

Bonjour et merci pour votre réponse.

Malheureusement, j'obtiens toujours le même message d'erreur, quel que soit le serveur utilisé (Gmail, Hotmail ou Orange) :

Pièce jointe 586273

Il doit y avoir un blocage quelque part mais je ne sais pas où ? Serait-ce au niveau du pare-feu ?

Merci d'avance pour votre aide
Cordialement,

Philippe
10/12/2020, 10h30
hyperion13

Salut
Selon ce que je viens de lire rapidement, il faudrait changer le port 465 en 587 ! Faites un essai, sait-on jamais.

Changement de serveur SMTP

Bonsoir,

Merci pour vos pistes de solution.

Dans l'intervalle, j'ai tenté d'utiliser tous les serveurs où je dispose d'une adresse de messagerie ainsi que celui mon fournisseur d'accès (Orange) et c'est ce dernier qui a fini par fonctionner.
Pour cela, j'ai dû paramétrer UseSSL sur True dans mon code. Le voici :

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
'Déclaration des variables
Dim objEmail As New CDO.message     'Objet Email (Microsoft CDO)
Dim i As Long   'Compteur de pièce jointe
 
'Paramétrer dans l'objet email l'adresse de l'expéditeur et celle du destinataire
objEmail.From = [Adresse expéditeur]
objEmail.To = [Adresse destataire]
'Paramétrer le sujet dans l'objet email
objEmail.Subject = Sujet
'Paramétrer la configuration de l'objet email
With objEmail.Configuration.Fields
    .Item(CdoConfiguration.cdoSendUsingMethod) = 2
    .Item(CdoConfiguration.cdoSMTPAuthenticate) = 1
    .Item(CdoConfiguration.cdoSendUserName) = [Adresse email Orange]
    .Item(CdoConfiguration.cdoSendPassword) = [Mot de passe Orange]
    .Item(CdoConfiguration.cdoSMTPServer) = stmp.orange.fr
    .Item(CdoConfiguration.cdoSMTPServerPort) = 587
    'Désactiver UseSSL
    .Item(CdoConfiguration.cdoSMTPUseSSL) = False
    'Mettre à jour les paramètres dans l'objet email
    .Update
End With
'Envoyer l'email par SMTP
objEmail.Send

Merci à tous et à bientôt
Cordialement,

Philippe