Outlook extraire adresses emails des emails ?

Résolu/Fermé
Charlie - Modifié le 22 mai 2018 à 08:18
 hamza - 18 juin 2019 à 12:59
Bonjour,
comment peut on extraire les adresses emails des emails d'un dossier de Outlook pour en faire un fichier .csv
merci
Charles

53 réponses

Voila la version V2.0
Elle extrait dans Outlook la liste des emails (destinataire et émetteur) du dossier sélectionné
le problème du retour a la ligne dans Outlook 2007 est résolut

'Déclaration du tableau dynamique globale contenant la liste des emails
Dim emails() As String
'Extrait dans Outlook la liste des emails (destinataire et émetteur) du dossier sélectionné
'et crée un mail avec la liste des emails
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")
' initialisation du tableau
ReDim Preserve emails(1)
emails(1) = ""
'Creation du mail de résultat
Set myMailItemLog = myOlApp.CreateItem(olMailItem)
myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
myMailItemLog.Subject = "Email from Body - " & Now()
myMailItemLog.BodyFormat = olFormatPlain
'On stocke les emails dans le tableau
GetEmailFromFolder myOlApp.ActiveExplorer.CurrentFolder
emails(1) = (UBound(emails) - 1) & " adresses"
'Conversion du tableau en chaine
myMailItemLog.Body = Join(emails, vbCrLf)
myMailItemLog.Display
MsgBox emails(1), vbInformation, "Done"

End Sub
'Explore les dossiers (fonction réentrante)
Sub GetEmailFromFolder(MyFolder)
Dim myItemRec, myItem As Object
Dim myMailItem As Outlook.MailItem
'Tous les dossiers
For Each myItem In MyFolder.Folders
GetEmailFromFolder myItem
Next
'Tous les mails
For Each myItem In MyFolder.Items
If TypeName(myItem) = "MailItem" Then
Set myMailItem = myItem
'Destinataire
For Each myItemRec In myMailItem.Recipients
addMail myItemRec.Name, myItemRec.Address
Next
'emetteur
addMail myMailItem.SenderName, myMailItem.SenderEmailAddress
End If
Next
End Sub
'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà
Sub addMail(Nom, AdresseEmail)
Dim email As String
If Trim(AdresseEmail) <> "" And InStr(AdresseEmail, "@") Then
If Trim(Nom) = "" Then
Nom = AdresseEmail
End If
'Mise en forme du nom pour être bien reconnue par Outlook si on copie colle la liste dans le champs [À...]
Nom = Replace(Nom, ",", " ")
Nom = Replace(Nom, "@", "-")
Nom = Replace(Nom, ";", " ")
Nom = Replace(Nom, "'", "")
email = """" & Nom & """[" + AdresseEmail + "]"
'Pour excel on peu utiliser sous cette forme :
'email = """" & Nom & """" + vbTab + AdresseEmail
' ou
'email = "<A href=""mailto:" & AdresseEmail & """>" & Nom & "</A>"
'Vérification de l'unicité
Find = UBound(Filter(emails, email, True, vbTextCompare))
If Find = -1 Then
'On augmente la taille du tableau et on ajoute
ReDim Preserve emails(UBound(emails) + 1)
emails(UBound(emails)) = email
End If
End If
End Sub
27
debonnesaffaires
10 févr. 2009 à 15:56
Bonjour et bravo et merci pour votre aide à l'avance.
Voici mon problème:
j'ai fait un Emailing avec Word 2007. J'ai reçu des centaines de messages indiquant : message non remis.
Je ne peux pas ressaisir tout à la min pour renvoyer ces messages.
Les macros que vous avez fait ne marchent pas sur ces messages, car l'adresse mail à extraire est dans le corps du message.
Je souhaite avoir une liste Excel, car les adresses avec des ' ou des [ ] ne passeront pas, et si je dois tout recorriger à la main c'est pas possible.

Vous croyez que c'est possible tout ça ?

Exemple de message :

Certains des destinataires ou tous les destinataires n'ont pas reçu votre message.

Objet : Flash Info xxxxxx
Date : 10/02/2009 11:50

Impossible de contacter le(s) destinataire(s) suivant(s) :

xxxx.xxxx@xxxx.com le 10/02/2009 12:34
L'organisation à laquelle le message a été envoyé a indiqué qu'elle ne contenait pas ce compte de messagerie. Vérifiez l'adresse de messagerie du destinataire ou bien contactez le destinataire directement pour lui demander son adresse exacte.
<atlexc01.xxxxxx.local #5.1.1>
0
ioton12 > debonnesaffaires
29 mai 2009 à 18:15
Bonjour Merci à Inpec...

J'ai le même problème que "debonnesaffaires"...

S'il vous plai INPEC ! Sauve nous !!

Merci !
0
Merci pour cette macro, tu est vraiment très fort.

Alors je propose à mon tour une évolution de ta macro, à savoir, récupérer toutes les adresse email, même celle qui se trouvent dans le corps du message après un transfert tel que :


----- Message transféré ----
De : barbara mateus <tsibarjo@live.fr>
À : agnes terrier <bodymay@simicro.mg>; agnes terrier <agnesterrier@moov.mg>; amosse.stephanie@wanadoo.fr; André Géraud <andre.geraud@laposte.net>; Annelaure <annelaure@skisessions.com>; Bain <pbain@laposte.net>; beryl bain etc.......
etc...............

Encore bravo pour ta macro qui marche impécable, tu est trop fort
0
Bonsoir,

J'ai beaucoup apprécié votre script pour récupérer les adresses email dans les courriers contenus dans un dossier d'Outlook. Merci encore.
Je voudrais savoir s'il serait possible non pas de récupérer les adresses des expéditeurs, mais les adresses contenus dans le corps de ces courriers.
En fait, j'ai besoin de récupérer les emails erronées dans les mails d'erreus que je reçois après l'envoi d'emailings.

Un grand merci d'avance, car je suis ignorant en scripts...

Matthieu
0
MERCI !!! C'est grandiose comme astuce.
Bravo.
0