Sub ExtraireListeDistrib2XL()
'-<DN>- (*) 4 3 17 [arch:x]
'__________________________
'code à mettre dans Outlook
'NB: Important : Activer la référence "Microsoft Excel xx.0 Object Library"
Dim objContactGroup As Outlook.DistListItem
Dim objMember As Outlook.recipient
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim i&, nRow&, strPath$, strFilename$
'Dans Outlook, sélectionner au préalable une liste de diffusion
Select Case Application.ActiveWindow.Class
Case olExplorer
Set objContactGroup = Application.ActiveExplorer.Selection(1)
Case olInspector
Set objContactGroup = Application.ActiveInspector.CurrentItem
End Select
If TypeOf objContactGroup Is DistListItem Then
'Création d'un classeur vierge
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkBook = objExcelApp.Workbooks.Add
Set objExcelWorkSheet = objExcelWorkBook.Worksheets(1)
'-> ligne d'entête
objExcelWorkSheet.Range("A1:B1") = Array("Nom Contact", "Courriel")
nRow = 2
For i = 1 To objContactGroup.MemberCount
Set objMember = objContactGroup.GetMember(i)
objExcelWorkSheet.Cells(nRow, 1) = objMember.Name
objExcelWorkSheet.Cells(nRow, 2) = objMember.Address
nRow = nRow + 1
Next
objExcelWorkSheet.Columns("A:B").AutoFit
'Adapter le chemin de l'export
strPath = "C:\Tests\"
strFilename = strPath & objContactGroup.DLName & ".xlsx"
objExcelWorkBook.Close True, strFilename
MsgBox "Export Contacts terminé!", vbInformation, "Informations"
End If
End Sub