envois automatique d'email avec EXCEL et une MACRO

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