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

Outlook extraire adresses emails des emails ? [Résolu]

Réponse 2 / 53

ioton12
2 juil. 2009 à 15:14

je suis dsl Inpec, mais je pige rien au VBA !!

Explique moi STP !

Réponse 3 / 53

ioton12
2 juil. 2009 à 15:52

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

Réponse 4 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
27 août 2009 à 10:24

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

Matthieu
27 août 2009 à 10:34

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 > Matthieu
27 août 2009 à 11:12

C'est bon j'ai redémarré le pc et tout est rentré dans l'ordre.
En plus, ta macro fonctionne à merveille !
MERCI

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 53

tomichill
10 févr. 2009 à 18:26

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.

Réponse 6 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
2 juin 2009 à 01:54

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

ioton12
2 juin 2009 à 12:32

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 ;)

ioton12
29 juin 2009 à 10:53

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...

++

Réponse 7 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
1 juil. 2009 à 02:01

'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

Réponse 8 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
2 juil. 2009 à 12:06

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

ioton12
2 juil. 2009 à 16:12

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

alysse
23 sept. 2009 à 11:01

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

claudio
14 oct. 2009 à 16:03

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 ?

Phillecoy
2 janv. 2010 à 15:32

Bonjour,

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

Cdlt.

Phillecoy

Réponse 9 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
29 juin 2010 à 11:44

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

PatSmt
20 nov. 2013 à 12:14

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.

Réponse 10 / 53

dje-dje Messages postés 10415 Date d'inscription mardi 6 janvier 2004 Statut Modérateur Dernière intervention 28 janvier 2011 757
29 mai 2007 à 00:04

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.

Réponse 11 / 53

Charles
29 mai 2007 à 09:23

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.

Réponse 12 / 53

dje-dje Messages postés 10415 Date d'inscription mardi 6 janvier 2004 Statut Modérateur Dernière intervention 28 janvier 2011 757
29 mai 2007 à 18:39

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

Réponse 13 / 53

Sam
29 déc. 2007 à 16:21

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

Merci

Réponse 14 / 53

Gentilgentil
9 janv. 2008 à 18:12

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.

Réponse 15 / 53

inpec
26 juin 2008 à 11:17

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

Réponse 16 / 53

Donnerjack
26 juin 2008 à 17:34

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 Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
26 juin 2008 à 17:53

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

Laurent > inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016
21 août 2008 à 10:34

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.

Serge > inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016
13 janv. 2009 à 12:29

Bonjour et Bonne année à tous,
Merci beaucoup à Inpec pour cette petite macro qui m'a bien aidé !

Réponse 17 / 53

inpec Messages postés 33 Date d'inscription jeudi 26 juin 2008 Statut Membre Dernière intervention 31 octobre 2016 6
21 août 2008 à 11:03

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

Laurent
21 août 2008 à 11:44

La honte !
Et merci, ça marche est c'est exactement ce que je voulais !

tomichill > Laurent
20 nov. 2008 à 15:49

Pouvez vous me dire où parte les emails? Je lance la macro (c ma premiere) il me demande d'accepter ou non, j'accepter et je ne sais pas ce qu'il fait pendant ce temp et surtout ou il me stock les adresses...

inpec > tomichill
25 nov. 2008 à 14:32

il cree un mail avec la liste des emails

F-MTHY > inpec
31 déc. 2008 à 16:34

Bonjour,

Je viens de voir votre macro,et je dois dire que je la trouve particulièrement intéressante. Je souhaiterais savoir s'il est possible de la modifier afin de récupérer en même temps les noms de mes destinataires car je souhaite gérer une liste de désabonnement suite au retours des mails envoyés

Thierry

inpec > F-MTHY
2 janv. 2009 à 00:04

et voila

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).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

Réponse 18 / 53

bg62 Messages postés 23590 Date d'inscription samedi 22 octobre 2005 Statut Modérateur Dernière intervention 15 avril 2024 2 362
25 avril 2009 à 08:45

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

bg62 Messages postés 23590 Date d'inscription samedi 22 octobre 2005 Statut Modérateur Dernière intervention 15 avril 2024 2 362
29 mai 2009 à 18:26

personne pour windows mail sous vista ???

Réponse 19 / 53

inpec
1 juil. 2009 à 01:52

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

Réponse 20 / 53

ioton12
1 juil. 2009 à 09:50

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)

Outlook extraire adresses emails des emails ?

53 réponses

Discussions similaires

Newsletters