Outlook extraire adresses emails des emails ?

[Résolu/Fermé]
Signaler
-
 hamza -
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
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 41713 internautes nous ont dit merci ce mois-ci

Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
Bonjour a vous tous !
un petit mot pour vous dire que j'ai mis à jour la macro
http://www.inpec.fr/GetMailV4.bas
elle récupère à présent les numéros de téléphone dans le corps du mail.
Merci beaucoup c'est magique!!!

Bonjour, Bonsoir,
Un gigantesque merci pour ce sublime code. Efficacité redoutable !
Bravo et encore merci !
Daniel (www.cadacom.be)
Bonjour,

Je découvre qu'il est possible de faire du vba sur outlook. Imaginez cette joie en moi :D
VBA sur EXCEL me met déjà dans un sacré état alors Outlook ... !!!

Bref,
Est-il possible d'avoir ce code VBA mais qui:
  • ouvre un excel plutôt qu'un mail
  • Colonne du excel : Nom, prénom, tel (dans le corps du mail), adresse mail


Je sais que tout est possible. Je crois en vous @Inpec.

Merci d'avance
rien à dire, un grand merci.
je suis dsl Inpec, mais je pige rien au VBA !!

Explique moi STP !
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 = "<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
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
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
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 = "<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
Merci pour ta réactivité !
Par contre, je n'arrive plus à lancer les macros sous Outlook.
A chaque fois que je tente de le faire, j'obtiens le me ssage suivant :
"Les macros de ce projet sont désactivées. Référez-vous à l'aide..."

J'ai bien été modifier les paramètres dans le centre de sécurité et de confidentialité d'Outlook, mais rien de mieux..

Auriez-vous une idée ?
> Matthieu
C'est bon j'ai redémarré le pc et tout est rentré dans l'ordre.
En plus, ta macro fonctionne à merveille !
MERCI
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.
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
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 = "<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
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
Salut INPEC,

Merci pour ta réponse rapide !

J'ai un soucis, au lancement de la macro à cette ligne :
'Emetteur
addMail myMailItem.SenderName, myMailItem.SenderEmailAddress

Erreur d'éxécution '483' ...

Comment faire ?

Merci.

Bonne journée ;)
Bonjour Inpec,

J'ai toujours le même problème avec Outlook 2002.

je lance la macro, le "débogueur se lance et me renvois à la ligne :

'Emetteur
addMail myMailItem.SenderName, myMailItem.SenderEmailAddress

Erreur d'éxécution '483' ...

j'ai beau chercher sur le net, mais aucune infos la dessus...

Merci pour ton aide...


++
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
'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 = "<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
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
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
trouve le nom de la propriete qui le fait bien (avec l'email)
INPEC,

j'ai enfin trouvé, j'ai remplacer "myMailItem.SenderName", myMailItem.SenderEmailAddress par "findMail myMailItem.SenderName".

Merci mille fois pour ton aide !!

A bientot, pour dautre aventures VBA !

'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 = "<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
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
Bonjour inpec

merci pour tous ces codes, c est bien la 1ere fois ou j 'arrive à faire fonctionner qq chose.
J' ai utilisé un des premiers codes pour extraire les adresses emails dans la creation d'un nouveau mail, ca marche nickel, mais serait il possible en gardant ce code d'inclure les adresses emails des destinataires qui etaient en copie ?

ca serait vraiment super si ca pouvait marcher,

merci pour ton aide
Bonjour,

Votre proposition est généilae

Cependant , je tente de l'uutiliser dans un dossier de plus de 4000 email (des retours d'un emailing) et impossible de récupérer les adresses email contenues dans les messages avec expéditeur désigné

Que faire ?
Bonjour,

Merci pour ta macro qui m'a fait gagner des heures pour mes voeux.

Cdlt.

Phillecoy
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
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 = "<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
            '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
Bonjour Inpec

Je sais pas si tu a un répertoire ou tu range les message qui n'ont pas pu être distribués (Non remis :). J'ai testé la macro sur ce répertoire et cela ne marche pas. Elle fonctionne bien sur les autres.
J'ai copié un email normal reçu dans le folder de mes messages non distribués et ça récupère bien les adresses de l'email en question. Il semble qu'il s'agisse de la nature même de l'email de retour non distribué qui pose problème. A tu une idée a ce sujet ? Si tu veux je t'envoie des exemples à une adresse que tu veux.
Merci pour ta réponse.
Messages postés
10414
Date d'inscription
mardi 6 janvier 2004
Statut
Modérateur
Dernière intervention
28 janvier 2011
744
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.
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.
Messages postés
10414
Date d'inscription
mardi 6 janvier 2004
Statut
Modérateur
Dernière intervention
28 janvier 2011
744
Dans ce cas tente ta chance dans le forum programmation en precisant ta version de Outlook (Express, 2000, XP, 2003)
Bonjour,
Avez-vous trouvé la solution ?
Je recherche la même chose, à savoir, extraire les email contenu dans les emails ...

Merci
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.
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
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
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
arg je l'ai oublié dans le copier coller
Dim emails() As String
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
>
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016

Je suis ravi de trouver cette solution mais sans doute trop nul pour savoir la mettre ne oeuvre !
Bon : je crée un fichier excel, je fais "nouvelle macro", je met un nom quelconque, je fais modifier, je me trouve dans visual basic, je vais un copier coller du tout (de Dim emails...à End Sub). Je fais exécuter. Et là, il me dit à propos de "myOlApp As New Outlook.Application" : Erreur de compilation - type défini par l'utilisateur non défini

Bon... et moi je fais quoi ?
Merci de votre aimable compétence.
>
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016

Bonjour et Bonne année à tous,
Merci beaucoup à Inpec pour cette petite macro qui m'a bien aidé !
Messages postés
33
Date d'inscription
jeudi 26 juin 2008
Statut
Membre
Dernière intervention
31 octobre 2016
6
c'est dans outlook qu'il faut créer la macro !!
bonjour inpec et bonne année
je cherchais à faire la même opération sur mes mails avec OL2007 et j'ai une erreur de compil sur la seconde sub ReDim incorrect sur ReDim Preserve emails(intMessageCount)
j'ai beau cherché, je trouve pas d'où ça vient.
Une idée ????


Sub GetEmail()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySelection As Selection
Dim myMailItemLog As Outlook.MailItem
Dim emails() As String
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).Name + " [" + myMailItem.Recipients.Item(1).AddressEntry + "]"
Else
strTemp = myMailItem.SenderName + " [" + 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
ça marche aussi sous Outlook 2007 je viens de tester.
je crois que tu as oublié de mettre la déclaration au dessus de la routine GetEmail() :


Dim emails() As String

Sub GetEmail()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
...
Messages postés
1
Date d'inscription
lundi 2 février 2009
Statut
Membre
Dernière intervention
3 février 2009
> inpec
génial inpec
ça marche
merci beaucoup
>
Messages postés
1
Date d'inscription
lundi 2 février 2009
Statut
Membre
Dernière intervention
3 février 2009

Bonjour Inpec,
Encore merci pour cette macro qui fonctionne super. Je voulais savoir si c'était normal que ça ne rapatrie pas les adresses emails qui sont en copie? Ça ne me donne que l'adresse des expéditeurs.
Merci,
Bonjour,

j'ai essayé votre macro mais à l'execution j'obtient: erreur d'execution 13 incompatibilité de type.
Le debogueur me renvoi à: Set myMailItem = myItem

merci pour votre assistance

me
Messages postés
23172
Date d'inscription
samedi 22 octobre 2005
Statut
Modérateur
Dernière intervention
10 octobre 2021
2 276
bonjour ... et sous Vista, pour un dossier spécifique dans WindowsMail ?
tu aurais qq chose à proposer ...
@+ b g
Messages postés
23172
Date d'inscription
samedi 22 octobre 2005
Statut
Modérateur
Dernière intervention
10 octobre 2021
2 276
personne pour windows mail sous vista ???
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 = "<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
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
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)