Liaison Exel-Outlook

Sub ExtraireContactsOutlook()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"


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, utilise 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