Extraire des adresses mails des messages
Fermé
catxav
Messages postés
15
Date d'inscription
vendredi 15 avril 2011
Statut
Membre
Dernière intervention
8 novembre 2011
-
17 juin 2011 à 15:46
catxav Messages postés 15 Date d'inscription vendredi 15 avril 2011 Statut Membre Dernière intervention 8 novembre 2011 - 17 juin 2011 à 17:30
catxav Messages postés 15 Date d'inscription vendredi 15 avril 2011 Statut Membre Dernière intervention 8 novembre 2011 - 17 juin 2011 à 17:30
A voir également:
- Récupérer les adresses mails de ces message reçu
- Recuperer message whatsapp - Guide
- Diff message ✓ - Forum Mobile
- Nom de l'adresse ✓ - Forum Réseaux sociaux
- Comment récupérer une adresse mail - Guide
- Recuperer video youtube - Guide
8 réponses
pasthou
Messages postés
11202
Date d'inscription
jeudi 24 juillet 2008
Statut
Membre
Dernière intervention
17 mars 2015
1 522
17 juin 2011 à 16:33
17 juin 2011 à 16:33
...sinon, en VB.....j'ai récupéré le code d'Impec :
[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
@+
pasthou
[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
@+
pasthou
