[Outlook] Récupérer adresses email

Merci pour cette macro. Elle marche du tonnerre.

J'ai fait cette Sub GetEmail qui recherche tous les emails des personnes qui t'ont envoyés un email ou qui tu as envoyé un email dans le dossier et les sous dossiers en cours de sélection (testé sous oulook 2003)
Sub GetEmail()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySelection As Selection
Dim myMailItemLog As Outlook.MailItem

Set myNameSpace = myOlApp.GetNamespace("MAPI")
ReDim Preserve emails(1)
emails(1) = ""
'Create a new email to use as log file
Set myMailItemLog = myOlApp.CreateItem(olMailItem)
myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
myMailItemLog.Subject = "Email from Body - " & Now()
myMailItemLog.BodyFormat = olFormatPlain
myMailItemLog.Body = Now() & " Starting..." & vbCrLf & vbCrLf

'Go thru all folders
GetEmailFromFolder myOlApp.ActiveExplorer.CurrentFolder

For Each Email In emails
myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Email
Next
myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & " Done. Email addresses extracted: " & UBound(emails)
myMailItemLog.Display
MsgBox Now() & " Done. Email addresses extracted: " & UBound(emails), vbInformation, "Done"

End Sub
Sub GetEmailFromFolder(MyFolder)
Dim myMailItem As Outlook.MailItem
For Each myItem In MyFolder.Folders
GetEmailFromFolder myItem
Next
intMessageCount = UBound(emails)
For Each myItem In MyFolder.Items
If TypeName(myItem) = "MailItem" Then
Set myMailItem = myItem
If MyFolder = "Éléments envoyés" Then
strTemp = myMailItem.Recipients.Item(1).Address
Else
strTemp = myMailItem.SenderEmailAddress
End If
Find = UBound(Filter(emails, strTemp, True, vbTextCompare))
If Find = -1 Then
intMessageCount = intMessageCount + 1
ReDim Preserve emails(intMessageCount)
emails(intMessageCount) = strTemp
End If
End If
Next
End Sub