Const strServer = "MyServer" Const strMailbox = "MyMailbox" Const CdoPR_GIVEN_NAME = &H3A06001E 'First Name Const CdoPR_INITIALS = &H3A0A001E 'Initials Const CdoPR_SURNAME = &H3A11001E 'Last Name Const CdoPR_DISPLAY_NAME = &H3001001E 'Display Name Const CdoPR_ACCOUNT = &H3A00001E 'Alias Const CdoPR_TITLE = &H3A17001E 'Title Const CdoPR_COMPANY_NAME = &H3A16001E 'Company Const CdoPR_OFFICE_LOCATION = &H3A19001E 'Office Const CdoPR_HOME_TELEPHONE_NUMBER = &H3A09001E 'Phone Const CdoPR_HOME2_TELEPHONE_NUMBER = &H3A2F001E 'Home Phone 2 Const CdoPR_HOME_FAX_NUMBER = &H3A25001E 'Home Fax Const CdoPR_HOME_ADDRESS_STREET = &H3A5D001E 'Address Const CdoPR_HOME_ADDRESS_CITY = &H3A59001E 'City Const CdoPR_HOME_ADDRESS_STATE_OR_PROVINCE = &H3A5C001E 'State Const CdoPR_HOME_ADDRESS_POSTAL_CODE = &H3A5B001E 'Zip Const CdoPR_HOME_ADDRESS_COUNTRY = &H3A5A001E 'Country 'Const CdoPR_MANAGER_NAME = &H3A4E001E 'Manager Const CdoPR_OFFICE_TELEPHONE_NUMBER = &H3A08001E 'Business 'Phone Const CdoPR_OFFICE2_TELEPHONE_NUMBER = &H3A1B001E 'Business 'Phone 2 Const CdoPR_BUSINESS_FAX_NUMBER = &H3A24001E 'Fax Const CdoPR_ASSISTANT = &H3A30001E 'Assistant Const CdoPR_ASSISTANT_TELEPHONE_NUMBER = &H3A2E001E 'Asistant 'Phone Number Const CdoPR_MOBILE_TELEPHONE_NUMBER = &H3A1C001E 'Mobile Const CdoPR_PAGER_TELEPHONE_NUMBER = &H3A21001E 'Pager Sub GetOLListMembers_1() 'Tools - References : Microsoft Outlook ... Dim olOutlookApp As Outlook.Application Dim olNameSpace As Namespace Dim olAddList As AddressList Dim olDistList As AddressEntry Dim olListMember As AddressEntry Dim i As Integer Dim strDLName As String strDLName = "All Users - PARIS" Set olOutlookApp = New Outlook.Application Set olNameSpace = olOutlookApp.GetNamespace("MAPI") Set olAddList = olNameSpace.AddressLists("Global Address List") Set olDistList = olAddList.AddressEntries(strDLName) i = 2 For Each olListMember In olDistList.Members With Worksheets("Sheet3") .Cells(i, 1).Value = olListMember.Name i = i + 1 End With Next Set olOutlookApp = Nothing Set olNameSpace = Nothing Set olAddList = Nothing Set olDistList = Nothing End Sub Sub GetOLListMembers_2() Rem ****************************************** Rem Retrieve members of a distribution list Rem récupérer les membres d'une liste de diffusion Rem ****************************************** 'Tools - References : Microsoft CDO ... Dim olOutlookApp As Outlook.Application Dim olNameSpace As Outlook.Namespace Dim olAddList As Outlook.AddressList Dim olDistList As Outlook.AddressEntry Dim olListMember As Outlook.AddressEntry Dim objCDOSession As MAPI.Session Dim objCDOAE As MAPI.AddressEntry Dim i As Integer Dim strDLName As String strDLName = "+NA_CHE, PIMS Tips" 'Change to reflect the name of your distribution list strDLName = "All Users - Paris" 'strDLName = "All Employees-Amsterdam" Set olOutlookApp = New Outlook.Application Set olNameSpace = olOutlookApp.GetNamespace("MAPI") Set olAddList = olNameSpace.AddressLists("Global Address List") Set olDistList = olAddList.AddressEntries(strDLName) Set objCDOSession = CreateObject("MAPI.Session") objCDOSession.Logon "", "", False, False, 0 On Error Resume Next Cells(1, 1) = strDLName i = 2 For Each olListMember In olDistList.Members With Worksheets("Sheet3") .Cells(i, 1).Value = olListMember.Name Set objCDOAE = objCDOSession.GetAddressEntry(olListMember.ID) .Cells(i, 2).Value = objCDOAE.Fields.Item(CdoPR_OFFICE_LOCATION).Value .Cells(i, 3).Value = objCDOAE.Fields.Item(CdoPR_OFFICE_TELEPHONE_NUMBER).Value .Cells(i, 4).Value = objCDOAE.Fields.Item(CdoPR_MANAGER_NAME).Value .Cells(i, 4).Value = objCDOAE.Fields.Item(CdoPR_HOME_ADDRESS_COUNTRY).Value i = i + 1 End With Next objCDOSession.Logoff Set objCDOAE = Nothing Set objCDOSession = Nothing Set olDistList = Nothing Set olAddList = Nothing Set olNameSpace = Nothing Set olOutlookApp = Nothing End Sub