Listes de diffusion : Accédez à Outlook depuis Access via VBA

Dans cette page, nous allons voir comment faire, en VBA, pour accéder à Outlook. L'intérêt de cette démarche est de pouvoir, par exemple, envoyer des E-Mails en masse de manière automatique avec Excel ou Access. Nous utiliserons ici Access.

La base : Comment envoyer un message avec Outlook Via VBA ?

Dans votre module Access, vous allez commence par créer une procédure vide :

Sub UseOutlook()
End Sub

Dans cette procédure, vous allez créer un objet Outlook, cette manière :

Sub UseOutlook()
  Dim MonOutlook As Object
  Dim MonMessage As Object
  ' Ici sera installé le code proprement dit
  Set MonOutlook = Nothing ' On ferme !
End Sub

La suite n'est pas plus compliquée :

Sub UseOutlook()
  Dim MonOutlook As Object
  Dim MonMessage As Object
  ' On crée une instance d'Outlook :
  Set MonOutlook = CreateObject("Outlook.Application")
  ' Et on crée un élément Outlook, qui sera un message E-Mail :
  Set MonMessage = MonOutlook.CreateItem(0)
  Set MonOutlook = Nothing
End Sub

Définir les destinataires

Maintenant, c'est carrément enfantin : On utilise tout bêtement les propriétés :

To : A qui est destiné ce message
Cc : A qui veut-on envoyer une copie ?
Cci : A qui veut-on envoyer une copie invisible ?
Subject : Quel est le sujet du message (Le titre)
Body : Quel est le contenu (corps proprement dit) du message ?

Et la propriété Send pour envoyer le message (le placer physiquement dans la boîte d'envoi)

Sub UseOutlook()
  Dim MonOutlook As Object
  Dim MonMessage As Object
  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)
  MonMessage.To = "truc@machin.com"
  MonMessage.Cc = "bidule@machin.com"
  MonMessage.Bcc = "chose@machin.com"
  MonMessage.Subject = "Quel beau soleil"
  MonMessage.body = "N'est ce pas un beau temps pour aller à la piscine ?"
  MonMessage.send
  Set MonOutlook = Nothing
End Sub

Attacher un fichier

Attacher un ou plusieurs fichiers n'est pas non plus d'une complication extrême : Nous allons utiliser Attachments.Add pour arriver à nos fins :

Sub UseOutlook()
  Dim MonOutlook As Object
  Dim MonMessage As Object
  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)
  MonMessage.To = "truc@machin.com"
  MonMessage.Cc = "bidule@machin.com"
  MonMessage.Bcc = "chose@machin.com"
  MonMessage.Subject = "Quel beau soleil"
  MonMessage.body = "N'est ce pas un beau temps pour aller à la piscine ?"
  MonMessage.Attachments.Add "C:\Mes Documents\Zoulie Image.gif"
  MonMessage.send
  Set MonOutlook = Nothing
End Sub

Plusieurs destinataires dans chaque champ, plusieurs fichiers attachés

Voici la syntaxe a utiliser pour un envoi plus "touffu" :

Sub UseOutlook()
  Dim MonOutlook As Object
  Dim MonMessage As Object
  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)
  MonMessage.to = "marcel@machin.com;julien@chose.com"
  MonMessage.cc = "chef@machin.com;directeur@chose.com"
  MonMessage.bcc = "un.copain@supermail.com;une-amie@hotmail.com"
  MonMessage.Attachments.Add "C:\Mes Documents\Zoulie Image.gif"
  MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"
  MonMessage.Subject = "Je suis content"
  ' Le corps du message est divisé en 2 lignes :
  Corps = "Bonjour,"
  ' Chr(13) & Chr(10) = Touche ENTER
  Corps = Corps & Chr(13) & Chr(10)
  Corps = Corps & "Je vous envoie un message idiot."
  MonMessage.body = Corps
  MonMessage.send
  Set MonOutlook = Nothing
End Sub

Sécurité Outlook XP

Si vous utilisez Outlook XP, celui-ci est pourvu d'une sécurité intégrée, et visiblement difficile à contourner, concrétisée par cette boîte de dialogue :. Lorsque vous avez cette boîte de dialogue sous les yeux, vous ne pouvez PAS cliquer immédiatement sur OUI, mais vous devez attendre quelques secondes, le temps que vous lisiez bien et que vous preniez conscience de ce qu'il vous dit. Il ne vous prend pas pour un idiot, mais c'est uniquement pour éviter que le programme VBA clique lui-même sur Oui sans que vous ayez le temps de dire ouf : En effet, l'instruction SendKeys("{ENTER}") cliquerait à votre place. Je sais, c'est énervant, mais c'est aussi sécurisant...

Voici la page technique de Microsoft concernant la sécurité Outlook pour les développeurs

Utilisation de DAO pour créer notre liste de diffusion

Des exemples d'utilisation de base de DAO se trouve sur cette page.

Avant d'aller plus loint, assurez-vous d'avoir été (depuis le code VBA d'Access) dans le menu Outils/Référence, et d'avoir coché la case Microsoft DAO 3.6 Object Library (Ou 3.5, ou même une version antérieure si vous ne la trouvez pas.)

Nous allons imaginer que nous avons une table T_EMail, qui contient les données suivantes :

. Un prénom qui ne nous serira pas à grand chose d'autre qu'une identification plus aisée, un E-Mail en texte, et pas en lien hypertexte, et un champOui/Non, que j'ai nommé "Prendre", qui va simplement nous permettre de sélectionner certaines adresses plutôt que d'autres.

Afin de justement ne sélectionner que les adresses E-Mail désirées, nous allons créer cette requête R_EMailOui : , qui va simplement nous extraire les E-Mails pour lesquels la case est cochée. Pour l'exemple, nous aurions pu directement piocher tous les E-Mails dans la table, mais pour vous montrer plus d'options qui ne viennent peut-être pas spontanément à l'esprit, nous créons une requête.

Accès à cette requête par DAO

Depuis un module VBA d'Access, créez une nouvelle procédure, dans laquelle vous écrivez :

Sub UseDAO()
  ' Initialisation de l'accès DAO :
  Dim ListeEMail As Recordset
  Set ListeEMail = CurrentDb.OpenRecordset("R_EMailOui")
 
  ' *** Le code proprement dit sera installé ici ***
  
  ' Fermeture de la requête :
  ListeEMail.Close
  Set ListeEMail = Nothing
End Sub

Faisons un simple test de fonctionnement : Plaçons-nous sur le premier enregistrement et affichons le avec un MsgBox :

Sub UseDAO()
  Dim ListeEMail As Recordset
  Set ListeEMail = CurrentDb.OpenRecordset("R_EMailOui")
  ListeEMail.MoveFirst
  MsgBox ListeEMail("EMail")
  ListeEMail.Close
  Set ListeEMail = Nothing
End Sub

Maintenant que ça, ça marche, nous allons parcourir les enregistrements de la requête, un par un (Il y a donc 3 enregistrements) :

Sub UseDAO()
  Dim ListeEMail As Recordset
  Set ListeEMail = CurrentDb.OpenRecordset("R_EMailOui")
  ListeEMail.MoveFirst
  While Not ListeEMail.EOF
    MsgBox ListeEMail("EMail")
    ListeEMail.MoveNext
  Wend
  ListeEMail.Close
  Set ListeEMail = Nothing
End Sub

Il devrait donc afficher le premier E-Mail, puis le 2ème puis le 3ème, chaque fois dans un MsgBox séparé.

Création de la liste des E-Mails

Maintenant, nous allons faire exactement la même chose, mais nous n'allons pas les afficher, mais en faire une chaîne de caractères (ListeComplete) séparée par un point-virgule entre chaque E-Mail :

Sub UseDAO()
  Dim ListeEMail As Recordset
  Set ListeEMail = CurrentDb.OpenRecordset("R_EMailOui")
  ListeEMail.MoveFirst
  ListeComplete = " "
  While Not ListeEMail.EOF
    ListeComplete = ListeComplete & ListeEMail("EMail") & ";"
    ListeEMail.MoveNext
  Wend
  MsgBox ListeComplete
ListeEMail.Close
Set ListeEMail = Nothing
End Sub

Vous devriez voir cette boîte de dialogue apparaître une seule fois : . Cette chaîne de caractères va dond représenter presque exactement le champ To, Cc, ou Bcc de notre envoi de mail en masse. Je dis presque, car il faudrait juste encore retirer le tout dernier point virgule qui se trouve à la fin du dernier E-Mail : C'est très simple, il suffit de placer cette ligne juste avant le MsgBox :

ListeComplete = Left(ListeComplete, Len(ListeComplete) - 1)

Et enfin, construction de l'édifice complet

Nous savons donc comment envoyer un E-Mail Outlook via VBA et Access, et nous savons comment construire notre chaîne d'E-Mails : Il ne reste plus qu'à assembler le tout : L'exemple suivant envoie un courrier à webmaster@entreprise.com, avec, en copie cachée Bcc tous les E-Mails définis dans notre requête. Le sujet sera "Promotions sur les vacances", et le corps du texte sera "Bonjour, profitez de nos dernières actions pour la Tunisie". à la fin de l'exécution de la prodédure, voici ce que vous allez trouver dans la boîte d'envoi Outlook :

Voici le code magique qui va permettre ça :

Sub LaTotale()
  ' #######################
  ' # 1. Access via DAO : #
  ' #######################
  
  ' Initialisation :
  Dim ListeEMail As Recordset
  Set ListeEMail = CurrentDb.OpenRecordset("R_EMailOui")
  ListeEMail.MoveFirst
  ListeComplete = ""
  
  ' Parcourt de la requête :
  While Not ListeEMail.EOF
    ListeComplete = ListeComplete & ListeEMail("EMail") & ";"
    ListeEMail.MoveNext
  Wend
  
  ' On enlève le dernier point virgule :
  ' ListeComplete nous sera évidemment utile tout à l'heure :
  ListeComplete = Left(ListeComplete, Len(ListeComplete) - 1)
  
  ' Stop DAO :
  ListeEMail.Close 
  Set ListeEMail = Nothing
 
  ' #######################################
  ' # 2. Envoi de l'E-Mail avec Outlook : #
  ' #######################################
  
  ' Initialisation :
  Dim MonOutlook As Object
  Dim MonMessage As Object
  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)
  
  ' Préparation du message :
  MonMessage.to = "webmaster@entreprise.com"
  
  ' Récupération de la chaîne d'E-Mails Access :
  MonMessage.bcc = ListeComplete
  MonMessage.Subject = "Promotions pour les vacances"
  Corps = "Bonjour,"
  Corps = Corps & Chr(13) & Chr(10)
  Corps = Corps & "Profitez de nos dernières actions pour la Tunisie"
  MonMessage.body = Corps
  
  ' C'est parti :
  MonMessage.send
  
  ' Fermeture de la session Outlook :
  Set MonOutlook = Nothing
End Sub

Et voici une version modifiée qui permet d'envoyer un e-mail différent par personne. Cette solution est nettement plus personnalisée, et comme cette histoire d'attente artificielle entre chaque e-mail, imposé par le système a disparu avec les versions récentes (en tout cas 2010), c'est nettement plus pratique :

Sub EnvoiMail()
' Initialisation :
Dim MonOutlook As Object
Set MonOutlook = CreateObject("Outlook.Application")
Dim MonMessage As Object
Dim ListeEMail As Recordset
Set ListeEMail = CurrentDb.OpenRecordset("R_Invitemail")
ListeEMail.MoveFirst

' Parcourt de la requête
While Not ListeEMail.EOF
Set MonMessage = MonOutlook.createitem(0)
MonMessage.to = ListeEMail("EMail")
Corps = "Bonjour,"
Corps = Corps & Chr(13) & Chr(10)
Corps = Corps & "Profitez de nos dernières actions pour la Tunisie"
MonMessage.body = Corps
MonMessage.Subject = "Promotions pour les vacances"
MonMessage.send
ListeEMail.MoveNext
Wend

' C'est l'heure, on ferme !
ListeEMail.Close
Set ListeEMail = Nothing
Set MonOutlook = Nothing
End Sub

Et pour terminer, voici une version qui vous permet d'envoyer un mail en format HTML :

Sub EnvoiMail()
' Initialisation :
Dim MonOutlook As Object
' Set MonOutlook = CreateObject("Outlook.Application")
Set MonOutlook = Outlook.Application
Dim MonMessage As Object
Dim ListeEMail As Recordset
Set ListeEMail = CurrentDb.OpenRecordset("R_Invitemail")
ListeEMail.MoveFirst

' Parcourt de la requête
While Not ListeEMail.EOF
Set MonMessage = MonOutlook.CreateItem(0)
MonMessage.BodyFormat = olFormatHTML
MonMessage.to = ListeEMail("EMail")
Corps = TexteMail
MonMessage.HTMLBody = Corps
MonMessage.Subject = "Test"
MonMessage.send
ListeEMail.MoveNext
Wend

' C'est l'heure, on ferme !
ListeEMail.Close
Set ListeEMail = Nothing
Set MonOutlook = Nothing
End Sub

Function TexteMail()
Texte = "<html xmlns:v=""""urn:schemas-microsoft-com:vml"""" xmlns:o=""""urn:schemas-microsoft-com:office:office"""" xmlns:w=""""urn:schemas-"
Texte = Texte & "microsoft-com:office:word"""" xmlns:m=""""http://schemas.microsoft."
Texte = Texte & "com/office/2004/12/omml"""" xmlns=""""http://www.w3.org/TR/REC-html40"""">"
Texte = Texte & "<head>"
Texte = Texte & "<meta name=Generator content=""""Microsoft Word 14 (filtered medium)"""">"
Texte = Texte & "</head>"
Texte = Texte & "<body lang=FR-CH link=blue vlink=purple>"
Texte = Texte & "<p>"
Texte = Texte & "Texte <bold>sympa</bold>"
Texte = Texte & "</body>"
Texte = Texte & "</html>"
TexteMail = Texte
End Function