Les meilleurs sources pour Excel
Les meilleurs sources pour ExcelConsultez toutes les FAQ
Nombre d'auteurs : 10, nombre de questions : 65, dernière mise à jour : 26 mars 2022
Sommaire→Automation→Outlook- Extraire les pièces jointes de tous les dossiers Outlook
- Envoyer un mail contenant des liens hypertextes dans le corps du message.
- Créer un nouveau dossier dans la boîte de réception
- Vérifier si un nom existe dans la liste des contacts Outlook
- Ajouter un champ personnalisé pour chaque contact
- Extaire la liste de tous les rendez vous Outlook dans une feuille Excel
- Importer toute la liste et les propriétés des contacts Outlook dans une feuille de calcul .
Ce 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.
Vba
Sélectionnez
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 SubCréé le 15 mai 2007 par SilkyRoad
Vba
Sélectionnez
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 Sub
Un autre exemple en utilisant la méthode CDO.
Vba
Sélectionnez
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 SubCréé le 16 mai 2007 par SilkyRoad
Vba
Sélectionnez
Sub creationDossierDansBoiteReception()
Dim olApp As New Outlook.Application
Dim olSpace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olInbox As Outlook.MAPIFolder
Set olSpace = olApp.GetNamespace("MAPI")
Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
Set olFolder = olInbox.Folders.Add("nouveau dossier " & Format(Date, "yyyymmdd"))
End SubCréé le 16 mai 2007 par SilkyRoad
Vba
Sélectionnez
Sub controleLastName_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)
'Recherche dans le champ Nom
Set Cible = dossierContacts.Items.Find("[LastName] = ""mimi""")
'Un autre exemple qui utilise une variable pour définir la donnée à rechercher:
'Dim Mot As String
'Mot = "mimi"
'Set Cible = dossierContacts.Items.Find("[LastName] = '" & Mot & "'")
If Not Cible Is Nothing Then
MsgBox "Existe"
Else
MsgBox "N'existe pas"
End If
End SubCréé le 16 mai 2007 par SilkyRoad
La procédure vérifie si le champ personnalisé nommé "MonChampPerso" Existe pour chaque contact.
Si le champ n'existe pas , la macro va le créer et y insérer des informations.
Vba
Sélectionnez
Sub Controle_Ajout_ChampPerso_ContactsOutlook()
Dim olApp As New Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim usProp As Outlook.UserProperty
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Boucle sur les contacts
For Each Cible In dossierContacts.Items
'Renvoie Nothing si le champ n'existe pas
Set usProp = Cible.UserProperties("MonChampPerso")
If usProp Is Nothing Then
'olText définit le type de données que va contenir le champ
Set usProp = Cible.UserProperties.Add("MonChampPerso", olText)
'Ajoute données dans le champ
usProp.Value = "informations complémentaires personnelles"
Cible.Save
End If
Next Cible
End SubCréé le 16 mai 2007 par SilkyRoad
Vba
Sélectionnez
Sub ListeRDV()
'Nécessite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim OlApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim OlFolder As Outlook.MAPIFolder
Dim OlItems As Outlook.Items
Dim OlAppointment As Outlook.AppointmentItem
Dim i As Byte
Set OlApp = New Outlook.Application
Set OlMapi = OlApp.GetNamespace("MAPI")
Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)
Set OlItems = OlFolder.Items
'Remarque :
'la macro liste les rendez vous par ordre d'index (de création)
' et non par ordre de date
For Each OlAppointment In OlItems
With OlAppointment
i = i + 1
Cells(i, 1) = .Subject 'sujet
Cells(i, 2) = .Start 'début
Cells(i, 3) = .End 'fin
Cells(i, 4) = .RequiredAttendees 'convoqués
Cells(i, 5) = .OptionalAttendees 'invités
Cells(i, 6) = .Location 'lieu
End With
Next OlAppointment
Columns("A:F").AutoFit
Set OlApp = Nothing
End SubCréé le 17 juin 2007 par SilkyRoad
Testé avec Office 2007.
Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library".
Dans l'éditeur de macros:
Menu Outils
Références
Vba
Sélectionnez
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 Sub
Pour récupérer quelques informations spécifiques, utilisez la procédure suivante.
(Exemple: extraire les numéros de téléphone)
Vba
Sélectionnez
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 SubCréé le 8 juillet 2007 par SilkyRoad