Envoi de mail automatiques en VBA (2 erreurs dans le code)

Le 15/04/2020 à 01:11

Bonsoir tout le monde!

Ayant débuté le VBA depuis le début du confinement, je voulais d'abord vous remercier pour toutes les infos que j'ai pu trouver sur ce forum et qui m'ont bien aidé.

Je vous expose mon problème : cela fait plusieurs jours que je galère pour envoyer des mails en "automatique" avec Outlook en récupérant les infos (mail, nom contact…) dans un tableau Excel (où je coche les personnes à contacter) et le corps de mon mail dans un Word (l'idée étant de facilement modifier le contenu du mail et de pouvoir y mettre des images).

J'ai finalement réussi à faire tout cela en créant une boucle pour envoyer autant de mails que de "lignes" cochées ("X") dans mon tableau mais 2 problèmes se posent :

1 - La macro fonctionne bien avec mon premier mail (donc 1ere boucle) mais une erreur se produit sur le "OutMail.Display" quand il s'agit d'envoyer le 2ème mail ("le serveur distant n'existe pas ou n'est pas disponible"). Par contre quand je fais le "pas à pas détaillé" cela fonctionne très bien et ma macro va jusqu'à la fin. Je me suis dit que c'était peut être dû au temps de chargement d'Outlook alors j'ai essayé de mettre un "wait" mais cela ne change rien… J'ai essayer plein de modifs mais rien n'y fait…

2 - Les mails créés par cette macro ne s'envoient pas mais se stockent dans le dossier "envoi" d'Outlook et je dois l'ouvrir manuellement pour qu'ils s'envoient.

Voici mon code :

Sub Envoi_mail1()
'Variables Word
Dim wApp As New Word.Application
Dim Docname As String
Docname = ThisWorkbook.Path & "\Mailing\Prospec_Premier_Contact.docx"
Dim objDoc As Word.Document
Set objDoc = wApp.Documents.Open(Docname, ReadOnly:=True)

'Variables Outlook
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

'Variable de comptage de ligne
Dim i As Integer
i = 7

'Partie Word
With wApp
    .ActiveDocument.Select
    .Selection.CopyAsPicture
    .Quit
End With

'creer une boucle
For Each cell In Sheets("Mailing").Range("A7:A200")

'verifier si ce n'est pas la derniere ligne (case "nom" vide si tous les CE ont ete traites)
If Not Sheets("Mailing").Range("B" & i).Value = "" Then
    'Verifier si la premiere case contient un "X" et la quatrieme un email
    If Sheets("Mailing").Range("A" & i).Value = "X" And Sheets("Mailing").Range("E" & i) <> "" Then
        'Creation de l'email
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(olMailItem)

        OutMail.Display 'C'EST CETTE COMMANDE QUI BUG
        OutMail.GetInspector.WordEditor.Range.PasteAndFormat wdFormatOriginalFormatting

        With OutMail
        .To = Sheets("Mailing").Range("E" & i).Value
        .Subject = Sheets("Mailing").Range("C" & i).Value & ", Nous sommes votre partenaire idéal pour l'organisation de votre arbre de Noel!"
        .Send
        End With

        Set OutApp = Nothing
        'Set OutMail = Nothing

    i = i + 1
    Else: i = i + 1

    End If
Else: Exit Sub
End If

Next cell

End Sub

Je précise d'avance que c'est un fichier excel qui me servira dans mon boulot mais qui ne sera pas un outil officiel de ma boite (C'est juste pour moi!!). Merci d'avance pour votre aide ( ça commence à me rendre fou!!)

Le 15/04/2020 à 11:27

Bonjour,

essaie ceci.

Sub Envoi_mail1()
    'Variables Word
    Dim wApp As New Word.Application
    Dim Docname As String
    Docname = ThisWorkbook.Path & "\Mailing\Prospec_Premier_Contact.docx"
    Dim objDoc As Word.Document
    Set objDoc = wApp.Documents.Open(Docname, ReadOnly:=True)

    'Variables Outlook
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Set OutApp = CreateObject("Outlook.Application")
    'Variable de comptage de ligne
    Dim i As Integer

    'Partie Word
    With wApp
        .ActiveDocument.Select
        .Selection.CopyAsPicture
        .Quit
    End With

    'creer une boucle
    For i = 7 To 200

        'verifier si ce n'est pas la derniere ligne (case "nom" vide si tous les CE ont ete traites)
        If Not Sheets("Mailing").Range("B" & i).Value = "" Then
            'Verifier si la premiere case contient un "X" et la quatrieme un email
            If Sheets("Mailing").Range("A" & i).Value = "X" And Sheets("Mailing").Range("E" & i) <> "" Then
                'Creation de l'email

                Set OutMail = OutApp.CreateItem(olMailItem)

                OutMail.Display 'C'EST CETTE COMMANDE QUI BUG
                OutMail.GetInspector.WordEditor.Range.PasteAndFormat wdFormatOriginalFormatting

                With OutMail
                    .To = Sheets("Mailing").Range("E" & i).Value
                    .Subject = Sheets("Mailing").Range("C" & i).Value & ", Nous sommes votre partenaire idéal pour l'organisation de votre arbre de Noel!"
                    .Send
                End With

                Set OutMail = Nothing

            End If
        Else
            Exit Sub
        End If

    Next i

End Sub
Le 15/04/2020 à 13:59

Bonjour h2so4 et merci pour ta réponse! Merci d'avoir simplifier ma boucle mais voila le problème persiste toujours sur le .Display au 2eme passage. Cependant le message est différent :

Erreur d'execution '-2147023170 (800706be)' :

Erreur Automation

Echec de l'appel de procédure distante

Merci encore pour ton aide

Le 15/04/2020 à 14:03

bonjour,

ton image ne passe pas, mets le fichier plutôt que le lien.

Le 15/04/2020 à 14:08

Je met en pièce jointe le dossier zippé si ca peut t'aider. Merci!!

13dossier-ce.zip (737.67 Ko)
Le 15/04/2020 à 14:16

Bonjour,

désolé, je ne parviens pas à reproduire ce problème chez moi,

essaie ce bout de code pour vérifier si la création et l'affichage de 3 mails fonctionnent.

Sub aargh()
    Set ol = CreateObject("outlook.application")
    For i = 1 To 3
        With ol.createitem(0)
            .Subject = "test " & i
            .display
        End With
    Next i
End Sub

edit : je n'ai pas regardé ton fichier zippé

Le 15/04/2020 à 14:34

Oui j'ai bien 3 mails qui s'affichent .

Merci encore

Le 15/04/2020 à 14:46

bonjour,

essaie alors d'isoler l'instruction qui pose problème en la mettant en commentaire et en verifiant si l'affichage des mails fonctionne toujours.

par exemple

Sub Envoi_mail1()
    'Variables Word
    Dim wApp As New Word.Application
    Dim Docname As String
    Docname = ThisWorkbook.Path & "\Mailing\Prospec_Premier_Contact.docx"
    Dim objDoc As Word.Document
    Set objDoc = wApp.Documents.Open(Docname, ReadOnly:=True)

    'Variables Outlook
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Set OutApp = CreateObject("Outlook.Application")
    'Variable de comptage de ligne
    Dim i As Integer

    'Partie Word
    With wApp
        .ActiveDocument.Select
        .Selection.CopyAsPicture
        .Quit
    End With

    'creer une boucle
    For i = 7 To 200

        'verifier si ce n'est pas la derniere ligne (case "nom" vide si tous les CE ont ete traites)
        If Not Sheets("Mailing").Range("B" & i).Value = "" Then
            'Verifier si la premiere case contient un "X" et la quatrieme un email
            If Sheets("Mailing").Range("A" & i).Value = "X" And Sheets("Mailing").Range("E" & i) <> "" Then
                'Creation de l'email

                Set OutMail = OutApp.CreateItem(olMailItem)

                OutMail.Display 'C'EST CETTE COMMANDE QUI BUG
                'OutMail.GetInspector.WordEditor.Range.PasteAndFormat wdFormatOriginalFormatting

                With OutMail
                    .To = Sheets("Mailing").Range("E" & i).Value
                    .Subject = Sheets("Mailing").Range("C" & i).Value & ", Nous sommes votre partenaire idéal pour l'organisation de votre arbre de Noel!"
                    '.Send
                End With

                Set OutMail = Nothing

            End If
        Else
            Exit Sub
        End If

    Next i

End Sub
Le 15/04/2020 à 15:17

Effectivement cela envoie bien les 3 mails … c'est donc avec la partie de word que y'a un problème. Je vais essayer d'inclure la copie du fichier word dans la boucle on ne sait jamais histoire que cela copie pour chaque mail.

Le 15/04/2020 à 15:35

Bon ben ca me créé une autre erreur au moment d'ouvrir le word…. servant distant indisponible… ca me rend dingue!!

Le 15/04/2020 à 16:41

bonjour,

à tout hasard, essaie ceci

Sub Envoi_mail1()
    'Variables Word
    Dim wApp As New Word.Application
    Dim Docname As String
    Docname = ThisWorkbook.Path & "\Mailing\Prospec_Premier_Contact.docx"
    Dim objDoc As Word.Document
    Set objDoc = wApp.Documents.Open(Docname, ReadOnly:=True)

    'Variables Outlook
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Set OutApp = CreateObject("Outlook.Application")
    'Variable de comptage de ligne
    Dim i As Integer

    'Partie Word
    With wApp
        .ActiveDocument.Select
        .Selection.CopyAsPicture
    End With

    'creer une boucle
    For i = 7 To 200

        'verifier si ce n'est pas la derniere ligne (case "nom" vide si tous les CE ont ete traites)
        If Not Sheets("Mailing").Range("B" & i).Value = "" Then
            'Verifier si la premiere case contient un "X" et la quatrieme un email
            If Sheets("Mailing").Range("A" & i).Value = "X" And Sheets("Mailing").Range("E" & i) <> "" Then
                'Creation de l'email

                Set OutMail = OutApp.CreateItem(olMailItem)

                OutMail.Display 'C'EST CETTE COMMANDE QUI BUG
                OutMail.GetInspector.WordEditor.Range.PasteAndFormat wdFormatOriginalFormatting

                With OutMail
                    .To = Sheets("Mailing").Range("E" & i).Value
                    .Subject = Sheets("Mailing").Range("C" & i).Value & ", Nous sommes votre partenaire idéal pour l'organisation de votre arbre de Noel!"
                    '.Send
                End With

                Set OutMail = Nothing

            End If
        Else
            Exit Sub
        End If

    Next i
    wapp.quit
End Sub
Le 15/04/2020 à 17:41

Génial cela fonctionne et plusieurs mails s'affichent!!!

Par contre ils ne partent pas vu que le ".Send" est en commentaire. et la macro bug de nouveau si je réactive cette ligne.

Le 17/04/2020 à 18:07

Bonjour!

J'ai finalement réussi à résoudre mes problèmes :

J'ai fait une macro qui vérifie les différentes conditions pour l'envoi des mails et qui lance une autre macro qui elle crée le mail.

Sub Envoi_mail1()

    'Variable de comptage de ligne
    Dim i As Integer

    'creer une boucle
    For i = 7 To 200

        'verifier si ce n'est pas la derniere ligne (case "nom" vide si tous les CE ont ete traites)
        If Not Sheets("Mailing").Range("B" & i).Value = "" Then
            'Verifier si la premiere case contient un "X" et la quatrieme un email
            If Sheets("Mailing").Range("A" & i).Value = "X" And Sheets("Mailing").Range("E" & i) <> "" Then
            'lancer la macro qui cree le mail    
            Call Creation_mail1(i) 

            End If
        Else 
               'décocher les lignes cochées
            Sheets("Mailing").Range("A7:A200").Value = ""
            Exit Sub
        End If

    Next i

End Sub

Ma macro suivante vérifie que Outlook est ouvert (et l'ouvre si nécessaire),crée le mail et l'envoi individuellement.

Sub Creation_mail1(i)
    'Variables Word
    Dim wApp As New Word.Application
    Dim Docname As String
    Docname = ThisWorkbook.Path & "\Mailing\Prospec_Premier_Contact.docx"
    Dim objDoc As Word.Document
    Set objDoc = wApp.Documents.Open(Docname, ReadOnly:=True)

    'Variables Outlook
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem

    'Verifie si Outlook est ouvert
    If OutlookOuvert = False Then o = Shell("Outlook", vbNormalNoFocus)
    Set OutApp = CreateObject("Outlook.Application")
    'Partie Word
    With wApp
        .ActiveDocument.Select
        .Selection.CopyAsPicture
    End With
     'creation de l'email 
    Set OutMail = OutApp.CreateItem(olMailItem)
    'affichage du mail                          
    OutMail.Display
    'Collage de la partie Word
    OutMail.GetInspector.WordEditor.Range.PasteAndFormat wdFormatOriginalFormatting
    'Remplissage du destinataire, du sujet   et envoi du mail          
    With OutMail
        .To = Sheets("Mailing").Range("E" & i).Value
        .Subject = Sheets("Mailing").Range("C" & i).Value & ", KING JOUET est votre partenaire ideal pour l'organisation de votre arbre de Noel!"
        .Send
    End With
    'fermer word
    wApp.Quit
End Sub

et voila tout fonctionne!! tous les mais sont envoyés et il suffit de fermer Outlook une fois tout parti!!

Merci à toi h2so4 pour ton aide et au forum d'exister!

Rechercher des sujets similaires à "envoi mail automatiques vba erreurs code"