Bonjour,
comment peut on extraire les adresses emails des emails d'un dossier de Outlook pour en faire un fichier .csv
merci
Charles
'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
Combien cela coûte-t-il au total ? Quelles aides apportent l'état et les acteurs du marché pour alléger cette charge non choisie ? Tous les détails sur Commentçamarche.net.
Avec une fonction pour supprimer les doublons dans Outlook !
Elle met en non lu les message en double, il n'y a plus qu'a les supprimer dans Dossiers de recherche - Courrier non lu