XL 2016 Comment détecter si mail envoyé

[Lolote83]

Bonjour à toutes et à tous,
Très régulièrement, je suis confronté a générer des mails automatiques en fonction de certaines données contenues dans mes classeurs.
Dans ce classeur, la macro qui rédige le mail est très simpliste et n'est en aucun cas en lien avec des données quelconques du classeur, mais le problème reste le même.
En fait, j'aimerai pouvoir détecter si la personne a bien envoyé le mail afin de pourvoir poursuivre la macro.

- Faire le traitement B si le mail n'a pas été envoyé (clic sur croix rouge).

- Faire le traitement A si le mail est bien envoyé (clic sur bouton Envoyé),

Je fais volontairement afficher le mail (display) afin de pouvoir, le cas échéant, y apporter des modifications de dernières minutes avant de cliquer sur le bouton ENVOYER.
Cependant, rien ne m’empêche de cliquer sur la croix rouge et hop, le mail ne part pas !!!!

La procédure jointe récupérée donne des résultats assez satisfaisants, mais la boucle de test tourne en rond si on clique sur la croix rouge (la macro n'est jamais vraiment arrêtée) et du coup je n'arrive pas à accéder au traitement B
Si clic sur la croix rouge,

En fait, il faudrait réussir a inter-réagir sur la boucle Test mais je n'y arrive pas ..... La macro tourne alors en boucle et on le constate par le fait que celle-ci est toujours active.... Pas de STOP ....

Merci pour vos retours

@+ Lolote83

 

[wDog66]

Bonjour,

A ma connaissance, sauf à grand renfort d'API (et pas sûr), ce n'est pas possible

C'est bien pour cette raison que l'on envoie directement le mail.
A la rigueur, faire une boite de dialogue qui affichera le message qui sera envoyé et donner la possibilité de le compléter. Ensuite vous envoyez le mail avec le message.

Cordialement.

 

[Lolote83]

Bonjour,
Merci pour ton retour.
J'attends encore un peu pour voir si d'autres personnes trouvent une solution....
Merci et bon week-end
@+ Lolote83

 

[fanch55]

Salut à tous,
A tester si le code corrigé qui fonctionne chez moi marche également ailleurs ...

Sub Envoi()
 
    Dim LolApp As Outlook.Application
    Dim LobjMail As Outlook.MailItem
 
    Set LolApp = New Outlook.Application
    Set LobjMail = LolApp.CreateItem(olMailItem)
 
    ' Création du mail
    With LobjMail
        .To = "toto@toto.fr"
        .CC = ""
        .Subject = "Ceci est un essai de mail automatique"
        .BodyFormat = olFormatHTML
        xBody = "Bonjour le Forum," & "<BR>" & "<BR>"
        xBody = xBody & "Comment détecter si le mail a été envoyé ??" & "<BR>" & "<BR>"
        xBody = xBody & "Si clic sur le bouton Envoyé alors on Traitement A" & "<BR>" & "<BR>"
        xBody = xBody & "Si clic sur croix rouge, alors Traitement B" & "<BR>" & "<BR>"
        .HTMLBody = xBody
        .Display
        On Error Resume Next
        Do
            DoEvents: Want = .Sent
            Select Case Err.Number
            Case 0
            Case -2009857782: MsgBox "Le message a été envoyé"
            Case Else: MsgBox "L'envoi n'a pas été fait" & vbLf & Err.Number & " " & Err.Description
            End Select
        Loop While Err.Number = 0
    End With
    
    ' On nettoie les variables
    Set LobjMail = Nothing
    Set LolApp = Nothing
End Sub

 

[patricktoulon]

re
Bonsoir @fanch55 l'idée est pas mal
mais a mon avis il manque un delay au bout d'un momment il faudrait pouvoir sortir de ce looping quand même
et peut être donc un err.clear quelque part

car par exemple il m'arrive d'envoyer des mail avec excel et je n'ai ni retours ni erreur mais le mail n'est pas parti quand je regarde dans mon app outlook ils sont dans les brouillons

 

[Lolote83]

Bonjour @wDog66 , @fanch55 , @patricktoulon ,

Fanch55, comme le dit à juste titre notre ami PatrickToulon, l'idée n'est pas mal, mais la boucle tourne toujours en rond si on clique sur la croix rouge. La macro ne s’arrête pas ....

J'ai mis un maximum d'explications dans mon fichier joint (copie d'écran) pour justement attirer l'attention sur ce problème (la macro tourne en rond et ne s’arrête pas ......)

De plus, j'ai remarqué que la valeur indiquée dans ton code (ici -2009857782) n'est jamais la même.

Do
            DoEvents: Want = .Sent
            Select Case Err.Number
            Case 0
            Case -2009857782: MsgBox "Le message a été envoyé"
            Case Else: MsgBox "L'envoi n'a pas été fait" & vbLf & Err.Number & " " & Err.Description
            End Select
        Loop While Err.Number = 0

Du coup, il est certainement préférable de passer par un case<0
Au final, comment sortir proprement de cette boucle ? faire un Exit Do quelque part ? afin de pouvoir faire le Traitement B

Si vous avez des idées ????
Je continue mes recherches.
Cordialement
@+ Lolote83

 

[kiki29]

Salut, peut-être via MailItem.Sent

 

[Nicos]

Bonjour,
si ça peut aider, une autre solution que demandé, un code que j'avais fait pour envoyer des relance devis automatiquement via fichier .bat dans le planificateur de tâche
et qui se lançait automatiquement toute les nuits.
A adapter bien sure.

Sub EnvoiMail_relance1_devis() 'automatique
Application.ScreenUpdating = False
    Dim ObjOutlook As New Outlook.Application
    Dim oBjMail As Outlook.MailItem
    Dim strbody As String, nom As String, nom2 As String, dev As String, ajout As String
    Dim Valeur_Cherchee As String, AdresseTrouvee As String, mail_t As String
    Dim Trouve As Range, PlageDeRecherche As Range
    Dim i As Integer
    Dim derdevis As Integer
    Dim dat1 As Date
    Dim nligne As Integer
 
    On Error Resume Next
    derdevis = Worksheets("acceuil").Range("H65536").End(xlUp).Row
 
    For i = 3 To derdevis
 
    dat1 = Range("I" & i).Value
    dev = Range("H" & i).Value
           
strbody = "<br><font style='font-family: Calibri;font-size: 11pt ;" & _
        "' font color=black>Bonjour," & _
        "<p>Vous m'avez sollicité pour la réalisation de travaux et je vous ai fait parvenir un devis" & " " & "<HTML><b>" & " " & "n°" & " " & dev & "</b><HTML>" & " " & "correspondant le" & " " & "<HTML><b>" & dat1 & "</b><HTML>" & "," & _
        "<br>celui-ci arrivant à expiration le" & " " & "<HTML><b>" & Range("M" & i).Value & "</b><HTML>" & _
        "<p>Je suis à ce jour resté sans réponse de votre part et j'aimerai savoir si vous avez maintenu votre projet." & _
        "<p>Sachez que je me tiens à votre disposition pour discuter des conditions qui vous ont été proposées et" & _
        "<br>vous apporter tout éclaircissement sur les différents postes de notre devis." & _
        "<p>Je vous adresse mes meilleures salutations." & _
        "<p><br><font style='font-family: Calibri;font-size: 9pt ;" & _
        "' font color=black>Message envoyé automatiquement." & _
        "</FONT>"
           
    Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
 
    nligne = Worksheets("acceuil").Range("J" & i).Value
    'Range("U" & I).Select
    nom = Worksheets("acceuil").Range("U" & i).Value 'nom du client sur la ligne de la page qui liste tout les devis en cours
    nom2 = Worksheets("clients").Range("Y" & i).Value 'code client dans la page "clients", et recupère toute les infos de celui-ci
    Valeur_Cherchee = nom ' de la ligne récupéré sur la page acceuil qui liste tout les devis en cours
    Set PlageDeRecherche = Worksheets("clients").Columns(25)
    Set Trouve = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, lookat:=xlWhole)
    mail_t = Trouve.Offset(0, -8).Value
 
If Range("G" & i).Value = "10" And Range("AB" & i).Value = "" Then '""""""si nombre de jour restant inférieur à 10 alors envoyer une relance"""""
 
    With oBjMail
        .Display
        .To = mail_t ' le destinataire
        '.CC = ""
        '.BCC = ""
        .Subject = "Relance du devis n°" & " " & dev & " " & "du" & " " & dat1
        .HTMLBody = strbody & " " & .HTMLBody
        '.Attachments.Add "C:\PDF Files\Booking Confirmation.pdf"
        .Display
        '.Send
    End With
 
    Set PlageDeRecherche = Nothing
    Set PlageDeRecherche = Nothing
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
 
    Range("AB" & i).Value = "x" '""" lettre x si relance envoyé """
 
    ajout = "1er relance envoyée le" & Chr(10) _
        & Range("A1").Value
   
         With Range("J" & i)
         Range("J" & i).Select
            .Comment.Text Text:=ActiveCell.Offset.Comment.Text & Chr(10) & Chr(10) & ajout ' + ajout d'un commentaire en cellule concerné sur la ligne client "1er relance envoyée le"
         End With
 
   With Range("J" & i).Comment.Shape
        .Width = 130 'Largeur commentaire
        .Height = 70 'Hauteur
        .OLEFormat.Object.Font.Size = 10 'Taille du texte
        .OLEFormat.Object.Interior.ColorIndex = 34 'Couleur de fond
        .TextFrame.Characters.Font.ColorIndex = 11 'Couleur de la police
        .TextFrame.Characters.Font.Bold = True 'Ecriture gras
        .OLEFormat.Object.Font.Name = "Bangle" 'Type de police
   End With
     
End If
 
    Next i
On Error GoTo 0
End Sub

 

[fanch55]

Du coup, il est certainement préférable de passer par un case<0
Au final, comment sortir proprement de cette boucle ? faire un Exit Do quelque part ? afin de pouvoir faire le Traitement B

On fait référence à l'objet Mailitem dans la boucle .
Tant que celui-ci est affiché, il n'y a pas d'erreur
Si celui-ci disparait ( suite à envoi ou croix rouge ), il y aura forcément une erreur et on sort de la boucle .
Pour le code -2009857782, il est vrai qu'il peut y en avoir un autre selon la situation,
je n'ai pas testé tous les cas .
Je vais réfléchir à une alternative ...

 

[fanch55]

Mince, il arrive qu'il n'y ait pas d'erreur si OUTLOOK a déjà été lancé ....

 

[Lolote83]

Re bonjour à tous.
Merci @Nico_J, je regarderai cette alternative
@fanch55, pour se rendre compte que l'on ne sort jamais de la boucle si clic sur la croix rouge, il suffit de mettre un msgbox ici et on ne peut plus l'arreter. Donc CTRL+SUPP pour sortir.
En fait, dans ta boucle, si Err=0 alors message NON envoyé, sinon, si Err<0 alors message ENVOYE

Donc a faire des tests avec ceci

On Error Resume Next
        Do
            DoEvents: Want = .Sent
                Select Case Err.Number
                    Case is = 0
                        msgbox "Message NON envoyé"
                        
                    Case is < 0
                        msgbox "Le message a été envoyé"
            
            End Select
        Loop While Err.Number = 0
    End With

Attention, comme je l'ai dit, la macro tourne en rond !!!!!
Je continue mes recherches
@+ Lolote83

 

[Nicos]

Mince, il arrive qu'il n'y ait pas d'erreur si OUTLOOK a déjà été lancé ....

Bonjour fanch55, je sais pas à qui cette réponse était dédié, mais pour mon poste, mon pc est branché H/24 et outlook toujours en marche et jamais eu aucun soucis, le fichier .bat lançait l'appli sans que je m'en apercoive et mail toujours envoyés avec le commentaire "envoyé le....."

 

[patricktoulon]

Mince, il arrive qu'il n'y ait pas d'erreur si OUTLOOK a déjà été lancé ....

re
c'est que j'ai dis hier

 

[patricktoulon]

re
le mieux je pense et d'explorer le dossier des "Envoyé"
un peu comme ca vite fait

Sub salutcommentcavatuvabienmoicava()
    Dim Oapp As Object, MaiL As Object, oK As Boolean
    Set Oapp = CreateObject("Outlook.Application")
    Set MaiL = Oapp.CreateItem(olMailItem)
    On Error Resume Next
    With MaiL
        .To = "toto@toto.fr"
        .CC = ""
        .Subject = "Ceci est un essai de mail automatique"
        .BodyFormat = olFormatHTML
        xBody = "Bonjour le Forum," & "<BR>" & "<BR>"
        xBody = xBody & "Comment détecter si le mail a été envoyé ??" & "<BR>" & "<BR>"
        xBody = xBody & "Si clic sur le bouton Envoyé alors on Traitement A" & "<BR>" & "<BR>"
        xBody = xBody & "Si clic sur croix rouge, alors Traitement B" & "<BR>" & "<BR>"
        .HTMLBody = xBody
        .Display
        .send
        sujet = .Subject
        If Err.Number Then MsgBox " ho la!! ya kékechoze ki va pas" & vbCrLf & Err.desciption: Exit Sub
    End With
    DoEvents
    oK = controlMailSent(Oapp, sujet)
    If oK Then
        Set Oapp = Nothing
    Else
        MsgBox " èè ben non  tu l'a dans le BABA c'est pas parti  et moi j'en reviens pas LOL!!!"
    End If

End Sub
Function controlMailSent(Oapp As Object, sujet) As Boolean
    Dim OutlookNamespace As Object, DossierOutlook As Object, OlkItem As Object, i As Integer, tim#
     Set OutlookNamespace = Oapp.GetNamespace("MAPI")
    Set DossierOutlook = OutlookNamespace.GetDefaultFolder(5)    ' 5 correspond au dossier Éléments envoyés
    tim = Timer
    Do While Timer - tim < 5
        DoEvents
        For Each OlkItem In DossierOutlook.Items
            If OlkItem.Subject = sujet Then controlMailSent = True: Exit Function
        Next OlkItem
    Loop
    Set OutlookNamespace = Nothing
    Set DossierOutlook = Nothing
    Set OlkItem = Nothing
End Function

 

[job75]

Bonsoir à tous,

Si le mail n'est pas envoyé la boucle tourne sans fin.

En mettant un compteur dans cette boucle avec un test il est facile d'en sortir quand le compteur dépasse une certaine valeur, non ?

A+