'cocher Microsoft Outlook xx Object Library
Sub ExchangeDistributionList()
Dim olApp As Outlook.Application
Dim NSpace As Namespace
Dim AdList As AddressList
Dim AdEntries As AddressEntries
Dim AdEntry As AddressEntry
Dim i As Long, j As Long
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
With Sheets("Feuil2")
.Cells.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
On Error GoTo 0
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
For Each AdEntry In AdEntries
If AdEntry.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
i = i + 1
.Cells(1, i) = AdEntry.Name
j = 1
On Error Resume Next
Set oMembers = AdEntry.GetExchangeDistributionList.GetExchangeDistributionListMembers
Select Case Err.Number
Case Is = 0
If oMembers.Count > 0 Then
For Each oMember In oMembers
j = j + 1
If oMember.AddressEntryUserType = olExchangeUserAddressEntry Then
.Cells(j, i) = oMember.GetExchangeUser.PrimarySmtpAddress
Else
.Cells(j, i) = oMembers.Parent.PrimarySmtpAddress
End If
Next oMember
End If
Case Else 'erreur d'exécution -2147221227
.Cells(2, i) = Err.Description: Err.Clear
End Select
End If
DoEvents
Next AdEntry
.UsedRange.EntireColumn.AutoFit
End With
MsgBox "Traitement terminé !"
End Sub