Outlook extraire adresses emails des emails ?Résolu/Fermé

Question

Bonjour,
comment peut on extraire les adresses emails des emails d'un dossier de Outlook pour en faire un fichier .csv
merci
CharlesConfiguration: Windows XP
Internet Explorer 6.0

inpec · Accepted Answer

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 = "" & Nom & "" '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

dje-dje · Answer

Tu peux exporter tes CONTACTS au format CSV.

Les adresses que tu veux dans ton CSV doivent donc d'abord être ajoutées en tant que contact dans Outlook.

Charles · Answer

Mais c'est pas ce que je veux...
Je souhaite une routine qui peut extraire les destinataires des mails d'un dossiers d'un coup.
Sans les passer par les contacts.
Merci
C.

dje-dje · Answer

Dans ce cas tente ta chance dans le forum programmation en precisant ta version de Outlook (Express, 2000, XP, 2003)

Sam · Answer

Bonjour,
Avez-vous trouvé la solution ?
Je recherche la même chose, à savoir, extraire les email contenu dans les emails ...

Merci

Gentilgentil · Answer

Je souhaite extraire des adresses email que j'ai reçues pour les copier dans un fichier Excel mais les adresses disparaissent et ne restent que les noms.

inpec · Answer

Par inpec, le jeudi 26 juin 2008 à 11:15:03     
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

Donnerjack · Answer

Hello,

J'ai essayé la macro et il me met "erreur de compilation : variable non définie" :
ReDim Preserve emails

Est-ce que vous pouvez m'aider ?
D'avance merci.

Frank

inpec · Answer

c'est dans outlook qu'il faut créer la macro !!

tomichill · Answer

Inpec tu maitrise ton sujet. Un grand merci, la V2 est vraiment efficcasse. Juste un petit clean de crochets et de doublons et le tour est joué.
Encore merci.

bg62 · Answer

bonjour ... et sous Vista, pour un dossier spécifique dans WindowsMail ?
tu aurais qq chose à proposer ...
@+ b g

inpec · Answer

Une nouvelle version qui devrait convenir ! 'Déclaration des tableaux dynamiques globaaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function '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 'et dans le corp du mail findMail myMailItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then addMail "body", Mid(Body, d + 1, f - d - 1) End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

inpec · Answer

je crois que j'ai trouvé ! 'Déclaration des tableaux dynamiques globaaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function '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 i = 0 'Tous les mails On Error Resume Next For Each myItem In MyFolder.Items If TypeName(myItem) = "MailItem" Then i = i + 1 If i = 75 And MyFolder = "ovh" Then i = i End If Set myMailItem = myItem 'Destinataire For Each myItemRec In myMailItem.Recipients addMail myItemRec.name, myItemRec.Address Next 'Emetteur addMail myMailItem.SenderName, myMailItem.SenderEmailAddress 'et dans le corp du mail findMail myMailItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then addMail "body", Mid(Body, d + 1, f - d - 1) End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

inpec · Answer

'Déclaration des tableaux dynamiques globaaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function '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 On Error Resume Next 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 'et dans le corp du mail findMail myMailItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then addMail "body", Mid(Body, d + 1, f - d - 1) End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

ioton12 · Answer

Salut INPEC,

Comment vas-tu ? Pas trop fatigué ;) !

Alors je viens à l'instant de tester la macro, résultat il me manque toujours les emails des émetteurs...par contre je ne rencontre pas de message d'erreur, j'ai récupère bien les emails du destinataire et dans le corps des emails...Malheureusement pas l'émetteur...

snif...:'(

Je compte sur toi Dieu du VBA...

PS : Ya t-il un rapport avec ma config ?? (Outlook 2002 sp2 / IMAP + XP)

inpec · Answer

j'ai essayer avec imap, pas de pb
je n'ai pas 2002 peut être  ?
si non dans le debugeur clic droit sur myMailItem fait ajouter espion ... puis ok ,  il doit y avoir un plus regarde si SenderEmailAddress et SenderName existe ?

ioton12 · Answer

Salut Inpec,

J'ai fais comme tu m'as dit....(ajouter un espion sur myMailItem)...

Je trouve bien SenderName, mais pas SenderEmailAddress ....

Si je met un espion sur myMailItem.SenderName, il me trouve bien le "nom" de l'émetteur, mais si je met un espion sur myMailItem.SenderEmailAddress, l'espion me dit : ''Propriété ou méthode non gérér par cet objet".

Voila !

Encore mille merci !

inpec · Answer

trouve le nom de la propriete qui le fait bien (avec l'email)

ioton12 · Answer

je suis dsl Inpec, mais je pige rien au VBA !!

Explique moi STP !

ioton12 · Answer

INPEC, j'ai trouvé !!! En fait j'ai changé : addMail myMailItem.SenderName, myMailItem.SenderEmailAddress En : FindMail myMailItem.SenderName Et ça marche !!! ;) En tout cas merci pour tout, c'est vraiement très gentil de ta part d'avoir répondu à mes post !! Bonne continuation ! et peut-être à bientôt pour d'autre Macro !! ++ 'Déclaration des tableaux dynamiques globaaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function '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 On Error Resume Next 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 findMail myMailItem.SenderName 'et dans le corp du mail 'findMail myMailItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then addMail "body", Mid(Body, d + 1, f - d - 1) End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

bg62 · Answer

euh ... (j'insiste ... mais bon ...) pour windows mail ... toujours rien ?
ou si je copie les fichiers *.eml dans un dossier à part, peut-on y arriver ? et comment ?
@+

inpec · Answer

Il y a du VBA sous Windows Mail ?
Essaie alt+F11 pour faire apparaitre la fenêtre Microsoft Visual Basic.
Pas de VBA =>  Il faut passer sous Outlook

inpec · Answer

et tu fais un glissé déplacé des fichiers vers Outlook. (Ctrl+a pour tous les sélectionner)

inpec · Answer

Réponse à Mattheiu : "(...) 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 (...)" Dans le script ci-dessous addMail myItemRec.name, myItemRec.Address récupère les adresses des destinataires addMail myMailItem.SenderName, myMailItem.SenderEmailAddress récupère l'adresse de l'expéditeur findMail myMailItem.Body récupère celles qui sont dans le corps du mails tu peux mettre les lignes en commentaire avec le caractère ' pour ne récupérer que les emails qui t'intéresse 'Déclaration des tableaux dynamiques globaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corps) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function '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 On Error Resume Next 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 'et dans le corp du mail findMail myMailItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then If Mid(Body, f - 1, 1) = "." Then addMail "body", Mid(Body, d + 1, f - d - 2) Else addMail "body", Mid(Body, d + 1, f - d - 1) End If End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

inpec · Answer

Merci

inpec · Answer

Re-Merci ;)
Je devais bien ça au net !!

clem_qui_depanne · Answer

Bonjour,

Je relance ce forum qui m'a bien aidé mais :

J'utilise outlook 2002

Il semble que myMailItem.SenderEmailAddress ne soit pas connu dans la librairie installée
Microsoft Outlook 10.0 Object library.

J'ai besoin de récupérer les adresses mails des expéditeurs des mails reçu dans un dossier donné.

Avez vous des coneils.

Si il faut installé une nouvelle library : help.

En vous remerciant par avance

inpec · Answer

Tu semblerais avoir le même problème que ioton12 qui nous donne sa solution message 42 : 
j'ai enfin trouvé, j'ai remplacer "myMailItem.SenderName", myMailItem.SenderEmailAddress par "findMail myMailItem.SenderName".(...)

j'en ai déduis que SenderName devait contenir l'e-mail de l'expéditeur sous 2002 ...
sinon ajoute un espion sur myMailItem (clic droit sur myMailItem, Ajouter un espion...),  tu devrais trouver la propriété qui le fait bien

sinon je t'ai déposé Microsoft Outlook 11.0 Object library ici : http://www.inpec.fr/MSOUTL.OLB en espérant qu'il se suffit à lui même !
Pour l'installer Menu outils dans VBA(alt+f11) ,Références,parcourir choisi le fichier téléchargé msoutl.olb

kudzou35 · Answer

Bonjour,

Merci Inpec pour les informations.

Pour la ref : elle ne peut pas se mettre sur outlook2002
Pour myMailItem.SenderName , il ne renvoit que le titre de la personne soit robert dupont
et non l'adresse e-mail.

En vous remerciant par avance pour vos autres lumières

inpec · Answer

Alysse, normalement c'est que font les lignes : 

            'Destinataires
            For Each myItemRec In myMailItem.Recipients
                addMail myItemRec.name, myItemRec.Address
            Next

kudzou35 · Answer

C'est bon j'ai trouvé ma solution grâce à https://support.microsoft.com/fr-fr/help/324530 bonne continuaation à tous 'Déclaration des tableaux dynamiques globaaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Dim myOlApp As New Outlook.Application Set rep = myOlApp.ActiveExplorer.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "email-" & rep & ".xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(Nom, Email) If Nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email Nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") Nom = Replace(Nom, "[", "") Nom = Replace(Nom, "]", "") Nom = Replace(Nom, "(", "") Nom = Replace(Nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = Nom + vbTab + Email + vcrlf End Function 'Explore les dossiers (fonction réentrante) Sub GetEmailFromFolder(MyFolder) Dim myItemRec, myItem As Object Dim myMailItem As Outlook.MailItem Dim objItem As MailItem Dim objReply As MailItem Dim objRecips As Outlook.Recipients Dim objRecip As Outlook.Recipient 'Tous les dossiers For Each myItem In MyFolder.Folders GetEmailFromFolder myItem Next 'Tous les mails On Error Resume Next For Each myItem In MyFolder.Items If TypeName(myItem) = "MailItem" Then Set myMailItem = myItem 'Destinataire 'Emetteur Set objItem = myItem Set objReply = objItem.Reply Set objRecips = objReply.Recipients For Each objRecip In objRecips addMail myMailItem.SenderName, objRecip.Address Next Set objItem = Nothing Set objReply = Nothing Set objRecip = Nothing 'et dans le corp du mail findMail myMailItem.Body End If Next Set objItem = Application.ActiveInspector.CurrentItem Set objReply = objItem.Reply Set objRecips = objReply.Recipients For Each objRecip In objRecips Debug.Print objRecip.Address Next Set objItem = Nothing Set objReply = Nothing Set objRecip = Nothing End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(Nom, Email) Email = Trim(LCase(Email)) Nom = Trim(Nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = Nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = Nom Else 'On préfère le plus grand si c'est pas une email If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then noms(Find) = Nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then addMail "body", Mid(Body, d + 1, f - d - 1) End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

inpec · Answer

pour le problème avec le fichier xls, c'est peut être qu'il est déjà ouvert ?
sinon sur le fond
as-tu regardé dans tes éléments supprimés ?
si c'est toi qui a envoyé le mail tu en as une copie dans les éléments envoyés et retrouvera là, la liste des destinataires cci.
si tu as reçu ce mail uniquement ( tu étais donc un destinataire cci de ce mail) il est IMPOSSIBLE de connaitre les autres destinataires de ce mail, c'est le principe.

Nicoxe · Answer

Bonjour,

J'ai un soucis avec la macro, ca doit être une bétise, mais il m'indique quand je la lance , erreur d'execution 75 - erreur d'accès chemin fichier.  c'est au niveau de la ligne nomfichier, je pense que c'est la ligne qui crée le XLS, mais je ne vois pas ce qu'il faut modifier. 

Faut il créer au paravant ce fichier?

Merci pour votre réponse.

A bientôt.

Nico

inpec · Answer

Non il ne faut pas créer le fichier
Votre fichier doit déjà être ouvert par Excel , au pire relacez votre machine.
ou remplacez la ligne
        NomFichier = "email-" & rep & ".xls"
par 
        NomFichier = "c:\le chemin ou j'ai le droit de créer un fichier sur ma machine\email-" & rep & ".xls"
ou bien 
        NomFichier = "c:\email-" & rep & ".xls"

fenlabiz · Answer

Houlala, je ne pige rien aux solutions et pourtant, j'ai un dossier nommé "prespection-envoyés"dans outlook 2003 et j'aimerais bien me faire un fichier avec tous les mails à qui j'ai envoyé un truc. Mais ils sont tellement nombreux que ça me donne le vertige de le faire manuellement.
Quelqu'un peut me donner une solution adaptée à mon cas ?
Merci 1000 fois par avance !
Francois

stephOffice · Answer

Bonjour,

Inpec tu es un dieu, ta solution marche nickel chrome :) et après pas mal de recherche sur le web je n'en ai pas trouvé de mieux.

Bravo!

inpec · Answer

Merci !

Fenlabiz · Answer

Bonjour !

Désolé, je vais vous paraitre stupide mais je n'y arrive pas, je reçois le message "Erreur de compilation" END SUB ATTENDU.

J'ai outlook 2003 et je veux récupérer les mails d'un dossier appelé "DIR COM".

Merci d'avance pour vos réponses !

Fenlabiz

stephOffice · Answer

Bonjour,

Comment faire pour des super grosses boite ( +34.000 mails)? 
on ne peut autoriser le script que pour une durée maximum de 10 minutes. Y-a-t-il moyen d'augmenter, voir passer outre cette limite?

Merci d'avance pour les réponses.

airdragon · Answer

INPEC, c'est génial ! 

Faudrait presque en faire un freeware (bien que ce soit expliqué pas à pas, et que tu ais pris le temps de commenter ton code, certains n'y arrivent toujours pas...).

Tu m'as fais gagné un temps précieux et je te remercie pour le temps que tu as consacré à cette macro.

Compte tenu de la récurrence des demandes, je pense qu'une version 3 serait envisageable avec une fonction supplémentaire : l'idée serait de pouvoir extraire les coordonnées des expéditeurs (présentes dans leur signature généralement, mais de manière non structurée, c'est à dire différente d'un email à un autre). 

La tâche est complexe, et mériterait un don ou un micropaiement via un appel à un serveur vocal par exemple.

Si l'idée t'intéresses, les champs qui me seraient utiles d'extraire sont les suivants :
- Nom
- Prénom
- Société
- Fonction
- Téléphone Fixe
- Téléphone Mobile
- Email

Si tu as une vision et le temps de t'y pencher, fais moi signe.

Sinon merci pour le travail accompli et bonne continuation.

pannouf · Answer

Bonjour et merci pour la macro,

Elle fonctionne parfaitement chez moi. Par contre, elle n'extrait pas les e-mails que Outlook appel les "rapports non remis". Il y a t il un moyen (je ne maîtrise pas totalement le VB) d'ajouter cette fonction à la macro ?

En vous remerciant d'avance,

inpec · Answer

La version V2.1 - 19/06/2010 à copier/coller dans ThisOutlookSession Pas de limite de temps, compatible office 2002 et windows 2003 64 bit 'Déclaration des tableaux dynamiques globaux contenant la liste des emails Dim emails(), noms() As String 'Extrait dans Outlook la liste des emails (destinataire, émetteur, corp) du dossier sélectionné 'et crée un mail avec la liste des emails Sub GetEmail() Set rep = Application.Session.CurrentFolder ' initialisation du tableau ReDim Preserve emails(1), noms(1) emails(1) = "" noms(1) = "" 'On stocke les emails dans le tableau GetEmailFromFolder rep If emails(1) <> "" Then NomFichier = "emails.xls" Close #1 Open NomFichier For Output As #1 For i = 1 To UBound(emails) Print #1, AfficheEmail(noms(i), emails(i)) Next Close #1 Call Shell("excel.exe " & """" & NomFichier & """") 'Conversion du tableau en chaine MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done" Else MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done" End If End Sub Function AfficheEmail(nom, Email) If nom = "" Then 'Si pas de nom on utilise la partie gauche de l'email nom = Mid(Email, 1, InStr(Email, "@") - 1) 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, "'", "") nom = Replace(nom, "[", "") nom = Replace(nom, "]", "") nom = Replace(nom, "(", "") nom = Replace(nom, ")", "") 'AfficheEmail = """" & Nom & """[" + Email + "]" 'AfficheEmail = "" & Nom & "" 'AfficheEmail = """" & Nom & """<" + Email + ">" AfficheEmail = nom + vbTab + Email + vcrlf End Function '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 On Error Resume Next For Each myItem In myFolder.Items If TypeName(myItem) = "MailItem" Then 'Destinataires (cc & cci) For Each myItemRec In myItem.Recipients addMail myItemRec.name, myItemRec.Address Next 'Emetteur (compatible avec office 2002) For Each myItemRec In myItem.Reply.Recipients addMail myItemRec.name, myItemRec.Address Next 'et dans le corp du mail findMail myItem.Body End If Next End Sub 'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà Sub addMail(nom, Email) Email = Trim(LCase(Email)) nom = Trim(nom) If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then 'Vérification de l'unicité Find = UBound(Filter(emails, Email, True, vbTextCompare)) If emails(1) = "" Then emails(1) = Email noms(1) = nom ElseIf Find = -1 Then 'On augmente la taille du tableau et on ajoute ReDim Preserve emails(UBound(emails) + 1) ReDim Preserve noms(UBound(noms) + 1) emails(UBound(emails)) = Email noms(UBound(noms)) = nom Else 'On préfère le plus grand si c'est pas une email If Len(nom) > Len(noms(Find)) And InStr(nom, "@") = 0 Then noms(Find) = nom End If End If End If End Sub Sub findMail(Body) at = InStr(Body, "@") Do While at > 0 d = at - 1 Do While carOk(Mid(Body, d, 1)) d = d - 1 If d = 0 Then Exit Do End If Loop f = at + 1 Do While carOk(Mid(Body, f, 1)) f = f + 1 If f = Len(Body) Then Exit Do End If Loop If d < at - 3 And f > at + 4 Then If Mid(Body, f - 1, 1) = "." Then addMail "body", Mid(Body, d + 1, f - d - 2) Else addMail "body", Mid(Body, d + 1, f - d - 1) End If End If at = InStr(at + 1, Body, "@") Loop End Sub Function carOk(c) If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then carOk = True Else carOk = False End If End Function

savonetbulle · Answer

Bonjour,

La macro marchait à merveille à l'époque.
Mais là quand je lance la macro dans Outlook, j'ai un message dans Virtual Basic Editor à l'execution qui me dit : " Les macros de ce projet sont désactivées. Référez-vous à l'aide en ligne ou à la documentation ........ "

Je dois récupérer mes adresses pour une campagne d'emailing c'est assez important.

Merci de votre aide et félicitations INPEC!

savonetbulle · Answer

Merci c'est sympa ;)

cooudin · Answer

Bonjour,

J'ai un message d'errur
ReDim Preserve emails(1), noms(1)

Merci

Yannick · Answer

Bonjour, 
Je n'ai aucune connaissance au VBA, mais j'ai reussi a la faire fonctionner, 
Merci A vous
Pouvez vous ajouter le fonction d'extraire les @ email qui sont egalement en copie dans les messages reçus ou expediés.
Merci A toi inpec

Yannick · Answer

PS j'ai utiliser un vertion anterieure, ca les dernire j'ai des ereurs

DLA · Answer

vraiment super ce script !!!

Merci INPEC

saber · Answer

Bonjour,

J'essaye désespérément d'extraire des adresses emails depuis le corps de mails de + de 1600 mails sur OL2010 mais sans succès.
J'avoue n'avoir jamais créé de macro et donc ne pas être sûr de mes manipulations.

J'ai collé ce code :

'Déclaration des tableaux dynamiques globaux contenant la liste des emails
Dim emails(), noms() As String
'Extrait dans Outlook la liste des emails (destinataire, émetteur, corps) du dossier sélectionné
'et crée un mail avec la liste des emails
Sub GetEmail()
Dim myOlApp As New Outlook.Application
Set rep = myOlApp.ActiveExplorer.CurrentFolder
' initialisation du tableau
ReDim Preserve emails(1), noms(1)
emails(1) = ""
noms(1) = ""
'On stocke les emails dans le tableau
GetEmailFromFolder rep
If emails(1) <> "" Then
NomFichier = "email-" & rep & ".xls"
Close #1
Open NomFichier For Output As #1
For i = 1 To UBound(emails)
Print #1, AfficheEmail(noms(i), emails(i))
Next
Close #1
Call Shell("excel.exe " & """" & NomFichier & """")
'Conversion du tableau en chaine
MsgBox UBound(emails) & " emails trouvés dans " & rep, vbInformation, "Done"
Else
MsgBox "Pas d'email trouvé dans " & rep, vbInformation, "Done"
End If

End Sub
Function AfficheEmail(Nom, Email)
If Nom = "" Then
'Si pas de nom on utilise la partie gauche de l'email
Nom = Mid(Email, 1, InStr(Email, "@") - 1)
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, "'", "")
Nom = Replace(Nom, "[", "")
Nom = Replace(Nom, "]", "")
Nom = Replace(Nom, "(", "")
Nom = Replace(Nom, ")", "")
'AfficheEmail = """" & Nom & """[" + Email + "]"
'AfficheEmail = "<A href=""mailto:" & Email & """>" & Nom & "</A>"
'AfficheEmail = """" & Nom & """<" + Email + ">"
AfficheEmail = Nom + vbTab + Email + vcrlf
End Function
'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
On Error Resume Next
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
'et dans le corp du mail
findMail myMailItem.Body
End If
Next
End Sub
'Rajoute une entrée au tableau emails() si l'email n'existe pas déjà
Sub addMail(Nom, Email)
Email = Trim(LCase(Email))
Nom = Trim(Nom)
If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then
'Vérification de l'unicité
Find = UBound(Filter(emails, Email, True, vbTextCompare))
If emails(1) = "" Then
emails(1) = Email
noms(1) = Nom
ElseIf Find = -1 Then
'On augmente la taille du tableau et on ajoute
ReDim Preserve emails(UBound(emails) + 1)
ReDim Preserve noms(UBound(noms) + 1)
emails(UBound(emails)) = Email
noms(UBound(noms)) = Nom
Else
'On préfère le plus grand si c'est pas une email
If Len(Nom) > Len(noms(Find)) And InStr(Nom, "@") = 0 Then
noms(Find) = Nom
End If
End If
End If
End Sub
Sub findMail(Body)
at = InStr(Body, "@")
Do While at > 0
d = at - 1
Do While carOk(Mid(Body, d, 1))
d = d - 1
If d = 0 Then
Exit Do
End If
Loop
f = at + 1
Do While carOk(Mid(Body, f, 1))
f = f + 1
If f = Len(Body) Then
Exit Do
End If
Loop
If d < at - 3 And f > at + 4 Then
If Mid(Body, f - 1, 1) = "." Then
addMail "body", Mid(Body, d + 1, f - d - 2)
Else
addMail "body", Mid(Body, d + 1, f - d - 1)
End If
End If
at = InStr(at + 1, Body, "@")
Loop
End Sub
Function carOk(c)
If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then
carOk = True
Else
carOk = False
End If
End Function

Ensuite presse le bouton « play » en étant sur le dossier voulu, ça bascule sur OL et il y'a un pop-up qui s'ouvre avec « Userform1 » en titre mais c'est tout. Rien ne se passe. Rien n'est extrait.

Est-il possible de me donner un coup de main ?

Merci d'avance.

adavid · Answer

Merci à toi inpec pour le script. Ca marche chez moi sur un dossier de 60 emails de retour erronés. J'ai suivi la démarche d'intégrer ton script VB (email.bas) qui se trouve sur http://www.inpec.fr/email.bas dans Outlook 2010 et ca marche. Petit bug: le script n'extrait pas les adresses emails courtes, par exemple to@titi.com. J'ai du modifier la ligne If d < at - 3 And f > at + 4 Then en If d < at - 2 And f > at + 4 Then et ca marche . Résumé: -il faudrait créer le fichier c:\emails.xls au préalable -activer menu "developeur" et aller sur VisualBasic et importer le fichier email.bas fourni par inpec. (recherche sur google le process activation de macro sur OL2010) -se positionner dans le dossier qui contient les adresses emails à extraire -lancer la macro getmail qui se trouve dans le menu "developer" (je suis sur OL2010 anglais) le résultat dans le fchier email.xls. ensuite il faut un effort dans excel : filter et effacer les emails de type postmaster@xxx.com,mailer-daemon@xxx.com merci

adavid · Answer

Oui , le folder ( dossier , repertoire) est dans OutLook2010  
comme montre sur cette page web
https://www.addictivetips.com/microsoft-office/how-to-create-new-folder-in-outlook-2010/
Je l'ai créé et drag&drop les messages dedans. 
Sur mon laptop (win7) , ce folder n'est pas sur le serveur ( par ex "Inbox" ) mais local (fichier archive pst) . Je ne suis pas pro de OL donc difficile a expliquer. 
Tu as raison,quand  je dis "ouvrir" le folder , en fait j'ai cliqué dessus et dans la fenetre de droite , les messages apparaissent .
Je ne comprend pas pq ca marche chez toi dans un folder, mais pas dans l'autre. Quelles differences entre les deux chez toi? Peut etre un est sur le serveur (sous ton compte exchange comme le folder inbox) et l'autre est local (dans le fichier archive pst) ?

J'espere que ca aide

Yanic · Answer

Bonjour,

j'ai un message d'erreur : 

Erreur de compilation :
Attendu : Numéro de ligne ou étiquette ou instruction ou fin d'instruction 

J'ai suivi la marche : 

Créer fichier : emails.xls 
importer le fichier http://www.inpec.fr/email.bas  dans Visual Basic 
Lancer la Macro sur le dossier sélectionné 

Si vous avez une solution..... merci beaucoup

yanic

deniz99 · Answer

Si tu peux exporter tes e-mails tu peux essayer un de ces logiciels :

https://www.email-finder.fr/en
https://fr.emailextractorpro.com/
https://captain-extractor.com/
http://www.supernova-soft.com/wpsite/

Voila bonne chance

Outlook extraire adresses emails des emails ?

53 réponses

Discussions similaires

Newsletters