envois automatique d'email avec EXCEL et une MACRO

[DomL]

Bonjour LE FORUM


Etant novice en informatique, je rencontre un problème avec une Macro trouvée sur Internet

15 jours de recherche d'une solution
et
je me résous, à me tourner vers LE FORUM : qui m'a toujours ''remis sur les rails''



D'un Tableau Excel, j'essaye d'envoyer des emails avec des pièces jointes par OUTLOOK

J'ai trouvé cette Macro, qui fonctionne ... avec un problème ... de taille, après 1 utilisation !

L'envoi, qui est censé être automatisé (à fonctionné 2 minute) ... puis :

- Bug.docx, en PJ :
* capture écran du pop up
* qui s'ouvre et me demande ... de confirmer ... chaque envoi !!!


- msg.Send : dans un premier temps est apparu un flèche jaune devant msg.Send


- après des recherches, je trouve : code erreur 287 VBA
* qui explique, que Outlook : peut ne pas être bien installé
* et pleins d'autres raisons


- je trouve par hasard :
* msg.Send
* Application.SendKeys "%s"
pour contourner le code erreur 287 VBA ...

... mais rien n'y fait :
* ca a fonctionné toujours 1 fois
* et la demande de confirmer à chaque envois, revient (Bug.docx)



Si quelqu'un avait une idée ... une solution ... je reste à son écoute et à toutes les autres

Merci d'avance



Macro :
Sub Envoi_mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Envoi mails")
Dim i As Integer
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("outlook.application")
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For i = 2 To last_row
If sh.Range("P" & i).Value <> "NON" Then
Set msg = OA.CreateItem(0)
msg.To = sh.Range("A" & i).Value
msg.CC = sh.Range("B" & i).Value
msg.BCC = sh.Range("C" & i).Value
msg.Subject = sh.Range("D" & i).Value
msg.Body = sh.Range("E" & i).Value
If sh.Range("F" & i).Value <> "" Then
msg.Attachments.Add sh.Range("F" & i).Value
End If
If sh.Range("G" & i).Value <> "" Then
msg.Attachments.Add sh.Range("G" & i).Value
End If
If sh.Range("H" & i).Value <> "" Then
msg.Attachments.Add sh.Range("H" & i).Value
End If
If sh.Range("I" & i).Value <> "" Then
msg.Attachments.Add sh.Range("I" & i).Value
End If
If sh.Range("J" & i).Value <> "" Then
msg.Attachments.Add sh.Range("J" & i).Value
End If
If sh.Range("K" & i).Value <> "" Then
msg.Attachments.Add sh.Range("K" & i).Value
End If
If sh.Range("L" & i).Value <> "" Then
msg.Attachments.Add sh.Range("L" & i).Value
End If
If sh.Range("M" & i).Value <> "" Then
msg.Attachments.Add sh.Range("M" & i).Value
End If
If sh.Range("N" & i).Value <> "" Then
msg.Attachments.Add sh.Range("N" & i).Value
End If
If sh.Range("O" & i).Value <> "" Then
msg.Attachments.Add sh.Range("O" & i).Value
End If
msg.Send
Application.SendKeys "%s"
sh.Range("Q" & i).Value = "Envoyé"
End If
Next i
MsgBox "Messages Envoyés"

End Sub
Sub EffacerD()
Range("D2300").ClearContents
End Sub
Sub EffacerE()
Range("E2:E300").ClearContents
End Sub
Sub EffacerF()
Range("F2:F300").ClearContents
End Sub
Sub EffacerG()
Range("G2:G300").ClearContents
End Sub
Sub EffacerH()
Range("H2:H300").ClearContents
End Sub
Sub EffacerI()
Range("I2:I300").ClearContents
End Sub
Sub EffacerJ()
Range("J2:G300").ClearContents
End Sub
Sub EffacerK()
Range("K2:K300").ClearContents
End Sub
Sub EffacerL()
Range("L2:L300").ClearContents
End Sub
Sub EffacerM()
Range("M2:M300").ClearContents
End Sub
Sub EffacerN()
Range("N2:N300").ClearContents
End Sub
Sub EffacerO()
Range("O2:O300").ClearContents
End Sub
Sub EffacerP()
Range("P2300").ClearContents
End Sub
Sub EffacerQ()
Range("Q2:Q300").ClearContents
End Sub

Sub Fichier()
Dim file_path As String
file_path = Application.GetOpenFilename(MultiSelect:=False)
If file_path <> "False" Then
Selection.Value = file_path
End If
End Sub

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @DomL
Pour ton message lors de l'envoi des mails par programme :

Comme Indiquer dans le message clique sur Aide, et tu connaîtras les paramètres à modifier dans OUTLOOK (sans doute dans le Centre de gestion de la confidentialité, puisque que c'est un paramètre de sécurité) - Je ne connais pas ta version ni d'excel ni d'outlook :

Ci-joint une version d'envoi des messages de ton tableau d'envoi (Macro EnvoiMail_tb_Envoi du module mdl_Mails)

J'ai renommé ton tableau "tb_Envoi", inutile de laisser des lignes vides en fin de tableau, les tableaux structurés s'étendent automatiquement lorsque l'on ajoute des données juste sous leur dernière ligne.

Chez moi cela fonctionne.
A bientôt

 

[DomL]

Bonjour à toutes & à tous, bonjour @DomL
Pour ton message lors de l'envoi des mails par programme :
Regarde la pièce jointe 1196570
Comme Indiquer dans le message clique sur Aide, et tu connaîtras les paramètres à modifier dans OUTLOOK (sans doute dans le Centre de gestion de la confidentialité, puisque que c'est un paramètre de sécurité) - Je ne connais pas ta version ni d'excel ni d'outlook :
Regarde la pièce jointe 1196573

Ci-joint une version d'envoi des messages de ton tableau d'envoi (Macro EnvoiMail_tb_Envoi du module mdl_Mails)

J'ai renommé ton tableau "tb_Envoi", inutile de laisser des lignes vides en fin de tableau, les tableaux structurés s'étendent automatiquement lorsque l'on ajoute des données juste sous leur dernière ligne.

Chez moi cela fonctionne.
A bientôt

Bonjour Alain

Merci pour ton aide ... mais le problème reste entier

Mon casse tête est pour mon travail ... toujours en retard : OUTLOOK 2016 !

Si je lance ton Tableau ... même résultat (voir Bug2)

L'explication Aide : est en anglais ... et j'ai beaucoup manqué, aux cours d'anglais ... quand j'étais jeune !

Je pensais que ce serait plutot dans Parametres des Macro

Alors que quand j'ai commencé, c'était la première ligne qui etait coché
et maintenant la dernière !!!
Sans que ca ne change rien

Le problème est toujours : SEND !

Je vais devoir m'orienter vers une autre solution, ce OUTLOOK doit être verrouillé de partout !!!
ou
l'utilisé comme une 2CV

 

[AtTheOne]

Re...
Le message Outlook indique clairement un problème de sécurité de Outlook, il faut aller dans les options d'Outlook, le centre de gestion de la confidentialité, Accès par programme, et, s'il n'y a pas d'antivirus actif sur votre système (ou si les mises à jour sont aléatoires), cocher Ne jamais m'avertir des activités douteuses.
Ça devrait régler le problème du message de confirmation lors des envois, mais c'est une fragilisation de la sécurité.

Pour le bug sur la ligne .Send, est-ce qu'il se produit si tu mets .Display à la place ?

A bientôt

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @DomL

Pas de réponse ?

Petite info complémentaire : pour modifier les paramètres OUTLOOK de l'accès par programme il faut exécuter OUTLOOK en tant qu'administrateur

Pour le message d'erreur 287 essaie cette version, on affiche les mails et on les envoie via Application.SendKeys comme tu l'avais tenter (mais tu m'utilisais pas au préalable .Display au lieu de .Send)
En utilisant .Display l'application active devient OUTLOOK et la combinaison de touches lui est envoyée.
Chez moi c'est CTRL ENTREE soit la chaîne "^~" , toi tu tentais ALT s soit la chaîne "%s".
Teste chez toi la chaîne à utiliser (moi ça m'a demandé une confirmation la première fois)

La macro propose 2 solutions : Avec OUTLOOK déjà ouvert ou en en créant une instance par programme

le code :

Sub EnvoiMail_tb_Envoi()
    
     Dim OutApp As Object, OutMail As Object
     Dim i%, nb_Mails%, tablo
     Dim à_envoyer() As Integer
     Dim Destinataire$, Nom$, Prénom$, Objet$, Corps$, j%
    
     'Mémorisation des données du tableau d'envoi
     tablo = sh_Envoi.[tb_Envoi]
     nb_Mails = 0
    
     'Constitution des index des mails à envoyer
     For i = 1 To UBound(tablo)
          If tablo(i, 1) <> "" And tablo(i, 16) <> "NON" And tablo(i, 17) <> "Envoyé" Then
               nb_Mails = nb_Mails + 1: ReDim Preserve à_envoyer(1 To nb_Mails)
               à_envoyer(nb_Mails) = i
          End If
     Next
     If nb_Mails = 0 Then MsgBox "Aucun mails à envoyer !": Exit Sub

     'Début de l'envoi
     Rép = MsgBox("Utiliser la version avec OUTLOOK déjà ouvert ?", vbYesNo, "Envoi de mails via EXCEL")
     If Rép = vbNo Then
         Set OutApp = CreateObject("Outlook.Application")
     Else
          On Error Resume Next
          Set OutApp = GetObject(, "Outlook.Application")
          On Error GoTo 0
          If OutApp Is Nothing Then
               MsgBox "Démarrer d'abord OUTLOOK"
               Exit Sub
          End If
     End If
    
     For i = 1 To nb_Mails
          Destinataire = tablo(à_envoyer(i), 1)
          Nom = tablo(à_envoyer(i), 2)
          Prénom = tablo(à_envoyer(i), 3)
          Objet = tablo(à_envoyer(i), 4)
          Corps = "Bonjour " & Prénom & " " & Nom & Chr(10) & tablo(à_envoyer(i), 5)
          
          Set OutMail = OutApp.CreateItem(0)
          With OutMail
               .To = Destinataire
               .Subject = Objet
               .Body = Corps
               'Constitution des pièces jointes
               For j = 0 To 9
                    If tablo(à_envoyer(i), j + 6) <> "" Then
                         .Attachments.Add tablo(à_envoyer(i), j + 6)
                    End If
               Next
               'Affichage du mail préparé
              .Display
              
              'Envoi du mail par combinaison de touches dans OUTLOOK
              'Pour envoyer chez moi c'est CTRL ENTREE
              Application.SendKeys "^~"   'envoie la combinaison CTRL ENTREE à OutLook pour envoyer le message
              'Application.SendKeys "%s"   'envoie la combinaison ALT s à OutLook pour envoyer le message
              DoEvents
    
     '         .Save           'si Sauvegarde du mail préparé
     '         .Send           'si Envoi du mail préparé
          End With
          
          Set OutMail = Nothing
          tablo(à_envoyer(i), 17) = "Envoyé"
     Next
    
     Set OutApp = Nothing
     'Mise à jour du tableau d'envoi
     sh_Envoi.[tb_Envoi].Value = tablo
     MsgBox nb_Mails & "mail(s)  envoyé(s)."
    
    
End Sub

Bon courage et à bientôt