[VBA] Envoi de mail avec Outlook sans message d'alerte

Le
HD
Bonjour,

Je souhaiterais pouvoir envoyer une série de mail avec des pièces
jointes propres à chaque destinataire. J'ai mon tableau avec mes
adresses emails destinataires ainsi que le fichier qui leur sera envoyé
en pièce jointe.

Lorsque je lance ma macro VBA, pour un mail j'ai le message "Un
programme tente d'envoyer un message électronique en votre nom." et cela
me demande d'attendre quelques secondes avant de cliquer sur
"Envoyer" Lorsque je lance ma macro pour toute une série de mail rien
ne se passe. Je suppose que c'est alors la sécurité Outlook qui bloque
les envois pour éviter les cas de spams.

Est il possible d'envoyer automatiquement en VBA des mails différents
pour une série de destinataires sans avoir ce message et en passant par
Outlook ? J'ai MSO 2010 sur mon poste mais je voudrais que ma macro
fonctionne avec des versions MSO également plus récentes.

A défaut, vais je être obligé de passer par l'utilisation de Windows
Mail ? d'un autre client de messagerie ? voir de Blat ?

Cordialement,

DAH
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michd
Le #26474749
Bonjour,
Il existe ceci, tu as des explications supplémentaires à l'adresse du site Web.
Perso. Je n'ai jamais eu à utiliser ceci.
Une autre alternative serait d'utiliser CDO, dis-le si cela t'intéresse!
À mettre dans un module standard...
Code Associated with Click me
http://www.contextmagic.com/express-clickyes/
' Microsoft Visual Basic (VB/VBA) Sample
' Declare Windows' API functions
Private Declare Function RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
'--------------------------------------------------------------------------
Sub SomeProc()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
' Register a message to send
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
' Find ClickYes Window by classname
wnd = FindWindow("EXCLICKYES_WND", 0&)
' Send the message to Resume ClickYes
Res = SendMessage(wnd, uClickYes, 1, 0)
' ...
' Do some Actions
' ...
' Send the message to Suspend ClickYes
Res = SendMessage(wnd, uClickYes, 0, 0)
End Sub
'----------------------------------------------------------------------
MichD
HD
Le #26474754
Une autre alternative serait d'utiliser CDO, dis-le si cela
t'intéresse!

L'inconvénient de CDO est que le mot de passe de la messagerie est alors
en clair dans le VBA.
À mettre dans un module standard...
Code Associated with Click me

Par contre, Click me ne fonctionne que lorsque l'on a l'alerte Outlook.
Mon souci est que pour plus d'un mail l'alerte ne s'affiche pas. La
boucle d'envoi continue son petit chemin sans aucun message d'alerte ou
message d'erreur...
@+
HD
Michd
Le #26474760
Sur ce site, tu as un tas d'exemples pour Mac ou Windows.
http://www.rondebruin.nl/search.htm
P.S. Outlook ne fonctionne pas. Je ne peux pas effectuer de tests.
MichD
Michd
Le #26474779
Si cela te tente, essaie cette procédure :
Tout ce qui suit dans le même module standard.
Certaines lignes peuvent être coupées par le service de messagerie, il faut alors remettre sur une
même ligne le cas échéant. La procédure n'a pas été testée sur une version Excel 2010.
'Déclaration des API dans le haut du module standard.
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String,
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal
hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long,
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Function ClickYes() As Long
Dim A As Long
Dim B As Long
A = FindWindow("#32770", "Microsoft Outlook")
B = FindWindowEx(A, 0, "Button", "Yes")
ClickYes = B
End Function
Function ClickYesOne() As Long
Dim A As Long
Dim B As Long
A = FindWindow("#32770", "Microsoft Outlook")
B = FindWindowEx(A, 0, "Button", "&Yes")
ClickYesOne = B
End Function
Private Sub Timer1_Timer()
SendMessageLong ClickYes, WM_LBUTTONDOWN, 0&, 0&
SendMessageLong ClickYes, WM_LBUTTONUP, 0&, 0&
SendMessageLong ClickYesOne, WM_LBUTTONDOWN, 0&, 0&
SendMessageLong ClickYesOne, WM_LBUTTONUP, 0&, 0&
End Sub
'-------------------------------------------------------------
Sub SendMail()
Dim C As Range
Dim outl As Outlook.Application
Set outl = New Outlook.Application
Dim mi As Outlook.MailItem
Call Timer1_Timer
'nom feuille et adresse de la plage de cellules à adapter
With Worksheets("Feuil1")
'un tableau de données
For Each C In .Range("A1:A4")
Set mi = outl.CreateItem(olMailItem)
'En colonne A, adresse des destinataires
mi.To = C.Value ' "" 'destinataire
'En colonne B, l'objet du courriel
mi.Subject = C.Offset(, 1).Value
'En colonne C, le corps du message
mi.Body = C.Offset(, 2).Value 'corps du message
'En Colonne D, le chemin et le nom du fichier
If C.Offset(, 2) <> "" Then
If Not IsNumeric(C.Offset(, 2)) Then
If IsDate(C.Offset(, 2).Value) = False Then
If Dir(C.Offset(, 2).Value) <> "" Then
mi.Attachments.Add C.Offset(, 2).Value
End If
End If
End If
End If
mi.Send
Set mi = Nothing
Next
End With
Set outl = Nothing
End Sub
'-------------------------------------------------------------
MichD
Michd
Le #26474783
Si cela ne fonctionne pas, dans la procédure "SendMail", déplace cette ligne de code
Call Timer1_Timer juste avant la ligne de code mi.send
MichD
HD
Le #26475904
Bonjour,
J'ai fini par me résoudre à utiliser le CDO. Cela fonctionne très bien.
Merci de votre aide.
Cordialement,
DAH
Publicité
Poster une réponse
Anonyme