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