[Outlook] Récupérer adresses emailFermé

Question

Bonjour,

je cherche à extraire les adresses emails d'Outlook 2003.
Non pas les emails mais juste les adresses emails de tous mes contacts, y compris ceux ne figurant pas dans mon carnet d'adresse....

Auriez-vous une piste ?

En vous remerciant,

Renaud B.
www.vousfairepart.com

Alex · Accepted Answer

Merci pour cette macro. Elle marche du tonnerre.

inpec · Answer

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

[Outlook] Récupérer adresses email

2 réponses

Discussions similaires

Newsletters