FAQ Excel

FAQ ExcelConsultez toutes les FAQ
Nombre d'auteurs : 46, nombre de questions : 845, dernière mise à jour : 30 mars 2022
Sommaire→Les macros VBA→piloter d'autres applications depuis Excel→Les messageries- Comment insérer une plage de cellules dans le corps du message ?
- Comment envoyer un fichier par mail sans Outlook ?
- Comment définir des notifications et des accusés de réception en utilisant la méthode CDO ?
- Pourquoi j'obtiens une erreur d'exécution sur la ligne .Send lorsque j'utilise la méthode CDO ?
- Comment envoyer un mail contenant des liens hypertextes dans le corps du message ?
- Comment indiquer des multi destinataires lors de l'envoi d'un classeur par la méthode SendMail ?
- Comment définir plusieurs destinataires lorque j'utilise la boîte de dialogue xlDialogSendMail ?
- Comment créer un message en utilisant Outlook Express ?
- Comment extraire les pièces jointes de tous les dossiers Outlook ?
- Comment lire des fichiers de type .msg stockés sur le disque dur ?
- Comment importer les contacts Outlook dans une feuille Excel, par macro ?
- Comment effectuer une recherche dans les contacts Outlook ?
- Comment ajouter un contact dans Outlook ?
- Comment créer un nouveau rendez vous dans le calendrier Outlook ?
- Comment créer une nouvelle tâche dans Outlook ?
Si vous disposez d'Excel 2002, ou ultérieur :
Sub envoiPlageCellules_Excel2002()
ActiveSheet.Range("A1:B5").Select ' la plage de cellules à envoyer
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = "bonjour , ci joint les données ..."
.Item.To = "destinataire@dvp.fr"
.Item.Subject = "le sujet"
.Item.Send
End With
End SubSinon, vous pouvez utiliser :
Sub PlageDeCellulesDansCorpsDuMessage()
'testé avec XP
'adapté de : http://support.microsoft.com/default.aspx?kbid=286430
Dim iMsg As Object, iConf As Object
Dim strHTML As String
Dim i As Byte, j As Byte
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour , <BR>vous trouverez ci joint le tableau demandé<BR><BR>"
strHTML = strHTML & "<B><SPAN STYLE='background-color:green;font-size:6mm'>Résultats : </SPAN></B><BR><BR>"
strHTML = strHTML & "<TABLE BORDER>"
For i = 1 To 5 'nombre de lignes (exemple plage A1:B5)
strHTML = strHTML & "<TR halign='middle'nowrap>"
For j = 1 To 2 'nombre de colonnes
strHTML = strHTML & "<TD bgcolor='yellow'align='center'><FONT COLOR='blue'SIZE=3>" _
& Cells(i, j) & "</FONT></TD>"
Next j
strHTML = strHTML & "</TR>"
Next i
strHTML = strHTML & "</TABLE>"
strHTML = strHTML & "<BR><BR>Cordialement<BR>" & Environ("username")
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
With iMsg
Set .Configuration = iConf
.To = "destinataire@dvp.fr" 'renvoie une erreur si l'adresse est non valide
'.From = "youralias@yourdomain.com"
.Subject = "Test Envoi Tableau par mail"
.HTMLBody = strHTML
.Send
End With
End SubLa fonction suivante permet la mise forme d'une plage de cellules dans la chaîne de caractères, pour ensuite l'insérer dans le corps du message :
Function corps(x As Range) As Variant
Dim ligne As Integer
Dim col As Integer
Dim moncorps As Variant
ligne = x.Rows.Count
col = x.Columns.Count
For ligne = 1 To x.Rows.Count
For col = 1 To x.Columns.Count
moncorps = moncorps & " " & x.Cells(ligne, col)
Next col
moncorps = moncorps & Chr(10)
Next ligne
corps = moncorps
End FunctionCe code permet depuis Excel de sélectionner une plage de cellules dans une feuille et d'envoyer
cette plage vers un nouvel E-mail d'Outlook.
ATTENTION :
Ce code doit être placé dans un module d'Excel. Ne pas omettre de cocher la
référence 'Microsoft Outlook xx.x Object Library.
Option Explicit
'-----------------------------------------------------------------------
'
' Lit le contenu d'un fichier texte et retourne son
' contenu
'
'-----------------------------------------------------------------------
Public Function ReadFile(sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fFile = fso.OpenTextFile(sFileName, 1, False)
sTemp = fFile.ReadAll
fFile.Close
Set fFile = Nothing
ReadFile = sTemp
End Function
'-----------------------------------------------------------------------'
' Cette routine va créer une instance de Outlook (si
' pas encore démarré) et va ensuite ouvrir une
' fenêtre de type mail. Le corps du message sera
' initialisé avec le contenu d'un fichier de type
' HTML. Ce fichier aura été préalablement
' créé par la routine SendRangeByMail
'
' Nécessite l'ajout d'une référence vers "Microsoft
' Outlook Object Library"
'
'-----------------------------------------------------------------------
Sub PrepareOutlookMail(ByVal sFileName As String)
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")
' Si Outlook n'était pas ouvert, l'instruction
' ci-dessus aura eu pour conséquence de
' démarrer Outlook.
'Ce type de démarrage par automation fait
'apparaître une fenêtre de sécurité qui demande
'à l'utilisateur de permettre au programme de
'continuer.
'
'Le message est "A program is trying to send an
'email. Do you want to allow..."
'
'Dans le cas où l'utilisateur aurait cliqué sur No,
'l'objet appOutlook est égal à Nothing. Il est
'donc impossible de continuer.
If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
oMail.HTMLBody = ReadFile(sFileName)
oMail.Display
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
'-----------------------------------------------------------------------
'
' La routine SendRangeByMail va proposer à
' l'utilisateur de sélectionner une plage de cellules
' en Excel et va ensuite envoyer cette plage par
' mail, dans le corps du mail.
'
'-----------------------------------------------------------------------
Sub SendRangeByMail()
Dim rngeSend As Range
With Application
On Error Resume Next
' Demande à l'utilisateur de sélectionner la
' plage de cellule
Set rngeSend = .InputBox(Prompt:="Please select range you wish to send.", Type:=8, Default:=.Selection.Address)
' rngeSend Is Nothing lorsque l'utilisateur ne fait
' aucun choix
If rngeSend Is Nothing Then Exit Sub
On Error GoTo 0
' Exporte la plage vers un fichier de type HTML;
' ceci afin de respecter la mise en page de la
' plage
.ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
' Appelle la routine qui va se charger de créer
' un mail
Call PrepareOutlookMail("C:\Temp\XLRange.htm")
' Le fichier HTML n'est plus nécessaire
Kill "C:\Temp\XLRange.htm"
End With ' With Application
End Sub
Via CDO, en cochant sous VBE Outils / Références "Microsoft CDO for Exchange xxxx Library".
A adapter à votre contexte, ici envoi de fichier Pdf :
Sub Envoi_CDO1()
Dim CdoMessage As CDO.Message
Dim Fichier As Variant
ChDir "C:\Documents and Settings\UserName\Mes documents\PdfOut"
Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf")
If Fichier = False Then Exit Sub
Set CdoMessage = New CDO.Message
With CdoMessage
.Subject = "Exemple"
.From = "xxxxx@wanadoo.fr"
.To = "yyyyy@orange.fr"
.CC = ""
.BCC = ""
.TextBody = "Texte dans le corps de message"
.AddAttachment Fichier
.Send
End With
Set CdoMessage = Nothing
End SubOu sans cocher de référence :
Sub Envoi_CDO2()
Dim CdoMessage As Object
Dim Fichier As Variant
ChDir "C:\Documents and Settings\UserName\Mes documents\PdfOut"
Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf")
If Fichier = False Then Exit Sub
Set CdoMessage = CreateObject("CDO.Message")
With CdoMessage
.Subject = "Exemple"
.From = "xxxxx@wanadoo.fr"
.To = "yyyyy@orange.fr"
.CC = ""
.BCC = ""
.TextBody = "Texte dans le corps de message"
.AddAttachment Fichier
.Send
End With
Set CdoMessage = Nothing
End SubPour envoyer la feuille active :
Option Explicit
Sub Tst()
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim Temp As String
Dim CdoMessage As Object
Dim Fichier As String
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
Temp = ThisWorkbook.Path & Application.PathSeparator & "Toto.xls"
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Destwb.SaveAs Temp
Fichier = Destwb.Path & Application.PathSeparator & Destwb.Name
Destwb.Close
Application.DisplayAlerts = True
Set CdoMessage = CreateObject("CDO.Message")
With CdoMessage
.Subject = "Exemple"
.From = "xxxxx@wanadoo.fr"
.To = "yyyyy@hotmail.fr"
.CC = ""
.BCC = ""
.TextBody = "Texte dans le corps de message"
.AddAttachment Fichier
.Send
End With
Application.ScreenUpdating = True
Set CdoMessage = Nothing
Kill Fichier
End SubPour le classeur complet :
Option Explicit
Sub Tst_Wb()
Dim SourceWb As Workbook
Dim CdoMessage As Object
Dim Fichier As String
Set SourceWb = ActiveWorkbook
Fichier = ThisWorkbook.Path & Application.PathSeparator & "Toto.xls"
SourceWb.SaveCopyAs Fichier
Set CdoMessage = CreateObject("CDO.Message")
With CdoMessage
.Subject = "Exemple"
.From = "xxxxx@wanadoo.fr"
.To = "yyyyy@orange.fr"
.CC = ""
.BCC = ""
.TextBody = "Texte dans le corps de message"
.AddAttachment Fichier
.Send
End With
Set CdoMessage = Nothing
'Kill Fichier
End SubOn pourra dans ce cas envisager d'envoyer le Classeur complet sans le code VBA.
Vous devez préciser le champ :
disposition-notification-to pour la notification.
return-receipt-to pour l'accusé de réception.
Sub EnvoiMail_AvecNotification_Et_AccuseReception()
'testé avec WinXP & Excel 2002
Dim iMsg As Object, iConf As Object
Set iMsg = CreateObject("cdo.message")
Set iConf = CreateObject("cdo.configuration")
With iMsg
Set .Configuration = iConf
.To = "destinataire@provider.fr"
'.From = "<valid e-mail address>"
.Subject = "Le sujet du message"
.HTMLBody = "Ceci est un essai ..."
.fields("urn:schemas:mailheader:disposition-notification-to") = "expediteur@provider.fr"
.fields("urn:schemas:mailheader:return-receipt-to") = "expediteur@provider.fr"
.fields.Update
.Send
End With
End Sub
L'adresse du serveur SMTP est nécessaire pour certains FAI.
Ce champ doit donc être précisé dans votre procédure :
Sub EnvoiMail_CDO()
Dim iMsg As Object, iConf As Object, Flds As Object
Set iMsg = CreateObject("cdo.message")
Set iConf = CreateObject("cdo.configuration")
Set Flds = iConf.fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'remplacez "smtp.nomserveur.fr" par le nom de serveur de votre FAI :
'https://outlook.developpez.com/faq/index.php?page=Configuration#Paras_FAI
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.nomserveur.fr"
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "destinataire@provider.fr"
.From = "emetteur@mail.fr"
.Subject = "Le sujet du message"
.HTMLBody = "Ceci est un essai ..."
.Send
End With
End SubConsultez la liste des Paramètres POP et SMTP des FAI Francophones.
Sub CreationMailEtLienHypertexte()
Dim OlApp As Outlook.Application
Dim OlItem As Outlook.MailItem
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Set OlApp = New Outlook.Application
Set OlItem = OlApp.CreateItem(olMailItem)
With OlItem
.To = "NomPrenom@mail.fr"
.Subject = "Le titre du message"
.Body = "Découvrez Microsoft Office sur le site Developpez" & _
vbLf & "http://www.developpez.com" & vbLf & vbLf & _
"Cordialement" & vbLf & "mailto:emetteur@mail.fr"
.Display
.Save
.Send
End With
Set OlItem = Nothing
Set OlApp = Nothing
End SubUn autre exemple en utilisant la méthode CDO.
Sub liensDansCorpsDuMessage_CDO()
'adapté de : http://support.microsoft.com/default.aspx?kbid=286430
Dim iMsg As Object, iConf As Object
Dim strHTML As String
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour , <BR>Découvrez Microsoft Office sur le site Developpez<BR><BR>"
strHTML = strHTML & "<A href='http://www.developpez.com'>Cliquez ici.</A>"
strHTML = strHTML & "<BR><BR>Cordialement<BR>" & Environ("UserName") & "<BR>"
strHTML = strHTML & "<A href=mailto:emetteur@mail.fr>Mon adresse mail</A>"
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
With iMsg
Set .Configuration = iConf
.To = "NomPrenom@mail.fr" 'Renvoie une erreur si l'adresse est non valide
'.From = "youralias@yourdomain.com"
.Subject = "Test Envoi liens par mail"
.HTMLBody = strHTML
.Send
End With
End SubLa liste des destinataires doit être spécifiée sous forme de tableau. Vous pouvez aussi utiliser les listes de distribution.
Sub EnvoiClasseur_MultiDestinataires()
'La méthode SendMail envoie le classeur en utilisant le système de messagerie installé.
'La liste des destinataire doit être spécifiée sous forme de tableau.
'Dans cet exemple "MaListeDeDistribution" est une liste de distribution existante dans
'la messagerie.
ActiveWorkbook.SendMail _
Recipients:=Array("MaListeDeDistribution", _
"AutreDestinataire01@mail.com", "AutreDestinataire02@mail.com"), _
Subject:="Rapport hebdomadaire " & ActiveWorkbook.Name, _
ReturnReceipt:=True
End Sub
La boite de dialogue xlDialogSendMail possède 3 arguments paramétrables :
destinataires, sujet, accusé de réception.
Vous pouvez l'utiliser ainsi dans votre macro :
Dim return_receipt As Boolean
Dim strRecipients As String, strSubject As String
'Copie la feuille active qui va être envoyée par mail
ActiveSheet.Copy
strRecipients = "destinataire@provider.fr"
strSubject = "Le sujet du message"
return_receipt = True
Application.Dialogs(xlDialogSendMail).Show _
strRecipients, _
strSubject, _
return_receipt
'Supprime le classeur envoyé
'ActiveWorkbook.Close FalseLes adresses multiples doivent être spécifiées dans un tableau Array :
Dim MailTab As Variant
MailTab = Array("mimi@test.fr", "riri@test.fr", "fifi@test.fr")
Application.Dialogs(xlDialogSendMail).Show MailTabSub MailOutlookExpress()
Dim Adresse As String, Sujet As String, Texte As String
Adresse = "Destinataire01@mail.fr;Destinataire02@mail.fr"
Sujet = "Le sujet"
Texte = "Bonjour," & vbCrLf & vbCrLf _
& "Vous trouverez ci joint les infos demandées" & vbCrLf & vbCrLf & _
"Cordialement" & vbCrLf & Environ("UserName")
Shell "C:\Program Files\Outlook Express\msimn.exe " & "/mailurl:mailto:" & _
Adresse & "?subject=" & Sujet & "&Body=" & Texte
End SubCe code permet, en pilotant Outlook par Automation, de boucler sur les messages de tous les dossiers Outlook (boite de réception, éléments envoyés, éléments supprimés ... et tous leurs sous dossiers) pour en extraire les pièces jointes et les enregistrer sur le disque dur.
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
Dim x As Integer
'La boite de réception, la boite des éléments supprimés et tous leurs
'sous dossiers sont pris en compte.
Sub ExportePiecesJointes()
Dim Ol As New Outlook.Application
Dim Ns As Outlook.Namespace
Dim Dossier As Outlook.MAPIFolder
Set Ns = Ol.GetNamespace("MAPI")
Set Dossier = Ns.Folders(1)
SearchFolders Dossier
x = 0
End Sub
Private Sub SearchFolders(ByVal Fld As Outlook.MAPIFolder)
Dim y As Integer
Dim OLmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
For Each SousDossier In Fld.Folders
If SousDossier.DefaultItemType = 0 Then
For Each OLmail In SousDossier.Items
If Not OLmail.Attachments.Count = 0 Then
For y = 1 To OLmail.Attachments.Count
Set pceJointe = OLmail.Attachments(y)
x = x + 1
pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
Set pceJointe = Nothing
Next y
End If
Next OLmail
End If
SearchFolders SousDossier
Next SousDossier
End Sub
Un fichier .msg est le format d'un message Outlook sauvegardé sur votre disque dur.
La méthode CreateItemFromTemplate permet de créer un objet Outloook afin de manipuler ce type de
fichier par VBA.
Vous pouvez ensuite piloter l'objet comme tout autre message qui serait stocké dans la messagerie.
Dim OutApp As Outlook.Application
Dim Message As Outlook.MailItem
Dim Cible As String
Cible = "C:\dossier\nom du message.msg"
Set OutApp = New Outlook.Application
Set Message = OutApp.CreateItemFromTemplate(Cible)
'Renvoie le nom de l'expéditeur et le contenu du message
MsgBox Message.SenderEmailAddress & vbCrLf & Message.Body
OutApp.Quit
Set OutApp = NothingCet exemple (testé avec Office 2007) extrait la liste des contacts Outlook et toutes leurs propriétés.
Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library".
Dans l'éditeur de macros :
Menu Outils
Références
Sub ExtraireContactsOutlook()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
'
'Créé avec Office 2007
'
Dim olApp As Outlook.Application
Dim dossierContacts As Outlook.MAPIFolder
Dim Contact As Outlook.ContactItem
Dim i As Integer, j As Integer
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Verifie si le dossier des contacts contient des éléments
If dossierContacts.Items.Count = 0 Then Exit Sub
'Création d'un entête dans la 1ere ligne
j = 1
For i = 0 To dossierContacts.Items(1).ItemProperties.Count - 1
Cells(j, i + 1) = dossierContacts.Items(1).ItemProperties.Item(i).Name
Next i
On Error Resume Next
'Boucle sur les éléments pour récupérer les infos
For Each Contact In dossierContacts.Items
j = j + 1
For i = 0 To Contact.ItemProperties.Count - 1
Cells(j, i + 1) = Contact.ItemProperties.Item(i).Value
Next i
Next Contact
Columns.AutoFit
MsgBox "Opération terminée."
End SubPour récupérer quelques informations spécifiques, utilisez la procédure suivante.
(Exemple: extraire les numéros de téléphone)
Sub numeroTelephone_contactsOutlook()
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
For Each Cible In dossierContacts.Items
Debug.Print Cible.HomeTelephoneNumber & vbTab & Cible.LastNameAndFirstName
Next
End Sub
Cet exemple recherche un contact dont l'adresse mail est saisie dans la cellule A1.
Si l'élément est trouvé, la procédure visualise la fiche complète.
Dim olApp As Outlook.Application
Dim dossierContacts As Outlook.MAPIFolder
Dim Contact As Outlook.ContactItem
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderContacts)
'Recherche le contact dont le nom est saisi dans la cellule A1
Set Contact = dossierContacts.Items.Find _
("[Email1Address] = '" & Range("A1") & "'")
If Not Contact Is Nothing Then
Contact.Display
Else
MsgBox "Non trouvé."
End IfSub ajouterContactOutlook()
'Nécessite d'activer la référence
'Microsoft Outlook xx.x Object Library
Dim objOutlook As Outlook.Application
Dim objContact As ContactItem
'Crée l'instance Outlook
Set objOutlook = New Outlook.Application
'Crée un élément pour les contacts
Set objContact = objOutlook.CreateItem(olContactItem)
'Définit les informations du nouveau contact
With objContact
.Email1Address = "silkyroad@redaction-developpez.com "
.FirstName = "michel"
.LastName = "dvp"
.HomeTelephoneNumber = "99 99 99 99 99"
.HomeAddressCity = "Xlcity"
'Sauvegarde le contact
.Save
End With
End SubSub NouveauRDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Set Rdv = OkApp.CreateItem(olAppointmentItem)
With Rdv
.MeetingStatus = olMeeting
.Subject = "le site DVP"
.Body = "...description ...."
.Location = "sur le forum Office"
.Start = #10/20/2007 9:30:00 PM# ' Attention : format mois/jours/année
.Duration = 30 'minutes
.Categories = "Amis"
.Save
End With
Set OkApp = Nothing
End Sub'Nécessite d'activer la référence Microsoft Outlook xx.x Object Library
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.TaskItem
'
Set myOlApp = New Outlook.Application
Set myItem = myOlApp.CreateItem(olTaskItem)
With myItem
.Status = olTaskInProgress
.Importance = olImportanceHigh
.DueDate = DateValue("10/23/07")
.Body = "Rendez vous sur le forum"
.TotalWork = 40
.ActualWork = 20
.Subject = "le titre"
.Assign
' le nom doit exister dans le dossier d'adresses
.Recipients.Add ("leNom lePrenom")
.Save
.Send
End With


