Impossible d'envoyer des mails macro VBA avec CDO

Le 16/07/2020 à 09:54

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.

capture 1 capture
Le 16/07/2020 à 10:04

Bonjour,

Si on avait le code ... pas une image ... ce serait plus motivant.

ric

Le 16/07/2020 à 10:42
40exemple.xlsm (25.50 Ko)

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 !

Le 16/07/2020 à 10:54

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
Le 16/07/2020 à 10:59

Je vais essayer et je vous redis ! Mais en tous cas merci d'avance

Le 16/07/2020 à 11:07

Re, malheureusement le transport a échoué donc c'est possiblement un problème de serveur ?

Le 16/07/2020 à 11:32

J'ai retesté mais effectivement ça n'a plus l'air de fonctionner. Microsoft a dû rajouter une sécurité sur le port 25.

Le 16/07/2020 à 11:38

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.

Le 19/07/2020 à 10:43

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.

Le 19/07/2020 à 13:34
thev a écrit :

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 !

thev a écrit :

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.

Le 19/07/2020 à 21:07

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.

Le 20/07/2020 à 07:50

est ce que ca marche avec gmail ? ou OVH ?

Le 20/07/2020 à 08:07

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 ?

Le 20/07/2020 à 08:09

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
Le 20/07/2020 à 19:55

merci

Le 21/07/2020 à 11:30

Merci à vous tous pour vos réponses je vais essayer de faire un mix de tout ça et je vous tiens au jus !

Rechercher des sujets similaires à "impossible envoyer mails macro vba cdo"