'cocher Microsoft Outlook xx Object Library
Sub Liste_nom()
Dim olApp As Outlook.Application
Dim NSpace As Namespace
Dim AdList As AddressList
Dim AdEntries As AddressEntries
Dim i As Long, T_AdEntries()
[A:B].ClearContents 'efface les valeurs précédentes
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application") 'cas où une session d'Outlook est déjà ouverte
If Err.Number <> 0 Then
Set olApp = New Outlook.Application 'cas où on doit créer une session d'Outlook
Err.Clear
End If
Set NSpace = olApp.GetNamespace("MAPI")
'on teste si ce compte utilise un serveur Exchange
If NSpace.ExchangeConnectionMode = olNoExchange Then
MsgBox "Ce compte n'utilise aucun serveur Exchange"
Exit Sub
End If
Set AdList = NSpace.GetGlobalAddressList 'on ramène la liste d'adresses globales
Set AdEntries = AdList.AddressEntries 'on ramène les entrées d'adresse
'on stocke les données dans un tableau
ReDim T_AdEntries(1 To 1000, 1 To 2)
For i = 1 To 1000 'ou AdEntries.Count mais ca risque d'être long s'il y en a beaucoup
T_AdEntries(i, 1) = AdEntries.Item(i).Name 'nom
T_AdEntries(i, 2) = AdEntries.Item(i).GetExchangeUser.PrimarySmtpAddress 'adresse mail
Next i
'on copie ces données dans la feuille de calcul
Range("A1").Resize(UBound(T_AdEntries), 2) = T_AdEntries
End Sub