Impossible d'envoyer des mails macro VBA avec CDO
Bonjour à tous, je me présente je suis étudiant en maintenance industrielle et j'aimerai réaliser un plan de maintenance préventive pour l'entreprise dans laquelle je suis en stage.
L'objectif étant d'envoyer un mail via CDO au responsable de l'atelier où a lieu l'intervention 7 jours avant afin qu'il s'y prépare et qu'il soit averti. Le soucis c'est l'envoi du mail sous CDO, ma macro s’arrête pendant quelques secondes en mode pas à pas au niveau du .send et repars sans envoyer le mail...
Malheureusement je ne peux partager le fichier excel car il y a des données sensibles qui y sont répertorié...
J'ai déjà parcouru quelques km de forum sans trouver de solutions je compte sur vous, tout cela sans pression bien sur !
J'ai également testé d'autres macro déjà faite et cela m'affiche "erreur d'automation", je précise aussi que j'ai bien activé la librairie CDO dans les références.
Cordialement, Pierre.
Bonjour,
Si on avait le code ... pas une image ... ce serait plus motivant.
ric
Excusez moi j'ai finalement enlevé ou remplacer les données sensibles et donc voici mon fichier, n'hésitez pas si vous avez des questions je suis disponible !
- Messages
- 4'094
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour,
ceci fonctionne :
Sub envoi_mail()
On Error Resume Next
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1
Set SMTP_Config = CDO_Config.Fields
With SMTP_Config
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "user@outlook.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "ppppppppppppp"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
Set CDO_Mail = CreateObject("CDO.Message")
With CDO_Mail
Set .Configuration = CDO_Config
.From = "user@outlook.fr"
.To = "xxxxxxxxxxx@gmail.com"
.Subject = "Le sujet du mail"
.TextBody = "Ce mail vous est envoyé pour tester la macro"
.Send
End With
'Libère les ressources
Set CDO_Mail = Nothing
Set CDO_Config = Nothing
Set SMTP_Config = Nothing
If Err <> 0 Then MsgBox Err.Description
End Sub
Je vais essayer et je vous redis ! Mais en tous cas merci d'avance
Re, malheureusement le transport a échoué donc c'est possiblement un problème de serveur ?
- Messages
- 4'094
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
J'ai retesté mais effectivement ça n'a plus l'air de fonctionner. Microsoft a dû rajouter une sécurité sur le port 25.
Personnellement j'utilise le port 587 qui m'a été donné par l'hébergeur réseau de l’entreprise. J'essaie de rentrer en contact avec l'hébergeur réseau pour plus d'information.
- Messages
- 4'094
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Je pense que l''utilisation de CDO a été bloquée par Microsoft .
Le plus simple est d'utiliser Office Outlook. On peut cependant utiliser un script Powershell vla la commande "Send-MailMessage" mais c'est une solution dont l'automatisation via VBA est plus compliquée à mettre en oeuvre.
Je pense que l''utilisation de CDO a été bloquée par Microsoft .
Bonjour,
je viens de faire un essai d'envoi par CDO et cela fonctionne sous orange
' Il faut activer la référence Microsoft CDO
Sub SendEmailUsingOrange()
On Error GoTo Err
Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String
Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
With NewMail
.Subject = "Test Mail"
.From = "moi@orange.fr"
.To = "moi@laposte.net" ' mettre ; entre chaque adresse mail
.CC = ""
.BCC = ""
'.TextBody = "Test envoi"
.HTMLBody = "Write your complete HTML Page"
'.AddAttachment "C:\Users\Michel\Downloads\test.xlsx"
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
'Enable SSL Authentication
.Item(msConfigURL & "/smtpusessl") = True
'Make SMTP authentication Enabled=true (1)
.Item(msConfigURL & "/smtpauthenticate") = 1
'Set the SMTP server and port Details
.Item(msConfigURL & "/smtpserver") = "smtp.orange.fr"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
'Set your credentials of your Gmail Account
.Item(msConfigURL & "/sendusername") = "moi"
.Item(msConfigURL & "/sendpassword") = "mdp"
'Update the configuration fields
.Update
End With
NewMail.Configuration = mailConfig
NewMail.Send
MsgBox ("OK, c'est parti !")
Exit_Err:
Set NewMail = Nothing
Set mailConfig = Nothing
End
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox " Could be no Internet Connection !! -- " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Incorrect Credentials !! -- " & Err.Description
Case Else 'Rest other errors
MsgBox "Error occured while sending the email !! -- " & Err.Description
End Select
Resume Exit_Err
End Sub
Néanmoins le serveur distant gmail m'a refusé et envoyé une alerte de sécurité critique me demandant de valider que c'était bien moi. Mais cela fonctionne aussi. Le problème n'est pas microsoft. quoique je n'ai jamais essayé CDO avec smtp outlook.
Conclusion cela fonctionne, mais c'est pointu à configurer, notamment le smtp !
Je pense que l''utilisation de CDO a été bloquée par Microsoft .
Le plus simple est d'utiliser Office Outlook. On peut cependant utiliser un script Powershell vla la commande "Send-MailMessage" mais c'est une solution dont l'automatisation via VBA est plus compliquée à mettre en oeuvre.
Je suis d'accord avec Thev que je salue, si tu utilises outlook, utilise le jusqu'au bout, le code est plus simple.
- Messages
- 4'094
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
quoique je n'ai jamais essayé CDO avec smtp outlook.
Effectivement CDO fonctionne avec le smtp orange et le smtp google, mais plus avec le smtp outlook.
J'aurais dû être plus précis : Je pense que l''utilisation de CDO a été bloquée par Microsoft pour le smtp outlook = smtp.office365.com. En tout cas, Microsoft Outlook.com ne donne pas le moyen comme Google de spécifier une exception de sécurité pour utiliser une application tierce comme CDO.
est ce que ca marche avec gmail ? ou OVH ?
Oui avec gmail ... il faudra autoriser l'envoi : après un test, tu vas dans ta messagerie gmail où il y aura une alerte de sécurité
' Il faut activer la référence Microsoft CDO
Sub SendEmailUsingGmail()
On Error GoTo Err
Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String
Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
With NewMail
.Subject = "Test Mail"
.From = "moi@gmail.com"
.To = "moi@orange.fr;moi@laposte.net" ' mettre ; entre chaque adresse mail
.CC = ""
.BCC = ""
'.TextBody = "Test envoi"
.HTMLBody = "Write your complete HTML Page"
'.AddAttachment "C:\Users\Michel\Downloads\test.xlsx"
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
'Enable SSL Authentication
.Item(msConfigURL & "/smtpusessl") = True
'Make SMTP authentication Enabled=true (1)
.Item(msConfigURL & "/smtpauthenticate") = 1
'Set the SMTP server and port Details
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
'Set your credentials of your Gmail Account
.Item(msConfigURL & "/sendusername") = "moi@gmail.com"
.Item(msConfigURL & "/sendpassword") = "mdp"
'Update the configuration fields
.Update
End With
NewMail.Configuration = mailConfig
NewMail.Send
MsgBox ("OK, c'est parti !")
Exit_Err:
Set NewMail = Nothing
Set mailConfig = Nothing
End
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox " Could be no Internet Connection !! -- " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Incorrect Credentials !! -- " & Err.Description
Case Else 'Rest other errors
MsgBox "Error occured while sending the email !! -- " & Err.Description
End Select
Resume Exit_Err
End Sub
Pourquoi ne pas utiliser outlook si tu es déjà sous outlook ?
avec OVH
Sub envoi(ligne As Long)
Dim Trouve As Range
Set Trouve = Sheets("Adresses Client").Columns("A").Find(what:=Cells(ligne, "B").Value, LookAt:=xlWhole)
If Trouve Is Nothing Then Exit Sub
envoyermail Trouve.Offset(0, 5).Value, ligne
End Sub
' Il faut activer la référence Microsoft CDO
Sub envoyermail(adressemail As String, ligne As Long)
On Error GoTo Err
Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String
Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
With NewMail
.Subject = "Estimation Delivery Date"
.From = "moi@fai.pro"
.To = adressemail
.CC = "moi@fai.pro"
.BCC = ""
.HTMLBody = "Hello<br><br>We are pleased to inform you that your order shipment number " & Cells(ligne, "A") & " with " & Cells(ligne, "G") & " pallets is in transit.<br>You should pick it up the " & Format(Cells(ligne, "L"), "dd/mm/yyyy") & " (dd/mm/yyyy)."
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
'Enable SSL Authentication
.Item(msConfigURL & "/smtpusessl") = True
'Make SMTP authentication Enabled=true (1)
.Item(msConfigURL & "/smtpauthenticate") = 1
'Set the SMTP server and port Details
.Item(msConfigURL & "/smtpserver") = "ssl0.ovh.net"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
'Set your credentials of your Account
.Item(msConfigURL & "/sendusername") = "moi@fai.pro"
.Item(msConfigURL & "/sendpassword") = "mldp"
'Update the configuration fields
.Update
End With
NewMail.Configuration = mailConfig
NewMail.Send
MsgBox ("Notification envoyée !")
Exit_Err:
Set NewMail = Nothing
Set mailConfig = Nothing
End
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox " Could be no Internet Connection !! -- " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Incorrect Credentials !! -- " & Err.Description
Case Else 'Rest other errors
MsgBox "Error occured while sending the email !! -- " & Err.Description
End Select
Resume Exit_Err
End Sub
Merci à vous tous pour vos réponses je vais essayer de faire un mix de tout ça et je vous tiens au jus !