Macro qui récupère les destinataires

Bonjour !
Comme promis, voici déjà une variante de ma macro anti-spam :
C'est une macro qui récupère les destinataires A, CC et CCi (si on est
l'expéditeur, bien sûr !) de messages sélectionnés, et qui renseigne la
Liste de distribution de son choix (si elle existe déjà bien sûr !)

Il suffit de la coller dans le code de ThisOutlookSession, de supprimer
les

retours à la ligne générés par Outlook Express, enregistrer, puis revenir
sous environnement Outlook classique.
Ensuite, sélectionner au moins un message et lancer la macro par
Outils/Macro/Macros... ThisOutlookSession.AjoutDansDistListe
(Si vous savez faire, créez un bouton avec la macro dans une barre
d'outils

!)

' Macro qui lit les destinataires de messages
' pour les mettre dans une liste de distribution

Sub AjoutDansDistListe()
Dim MonDoss As MAPIFolder
Dim MaListe As DistListItem
Dim MonEsp As NameSpace
Dim LeNomListe As String
Dim leNumliste As Integer
Dim intRep As Integer
Dim monExp As Explorer
Dim laSel As Selection
Dim i As Integer, intPos As Integer
Dim LeRecip As Outlook.Recipient
Dim leMess As MailItem
Dim DéjàDansListe As Boolean


Set monExp = ActiveExplorer
Set MonEsp = GetNamespace("MAPI")
Set laSel = monExp.Selection

If laSel.Count = 0 Then
MsgBox "Pas d'élément sélectionné !"
Exit Sub
End If
MsgBox "Sélectionnez le dossier contenant la liste"
Set MonDoss = MonEsp.PickFolder
If MonDoss Is Nothing Then
MsgBox "Pas de dossier sélectionné"
Exit Sub
ElseIf MonDoss.DefaultItemType <> olContactItem Then
MsgBox "Pas un dossier de type Contacts !"
Exit Sub
End If
Dim strListe As String
Dim j As Integer
ReDim tabListes(1 To MonDoss.Items.Count) As String
For i = 1 To MonDoss.Items.Count ' récup des listes de distrib
If TypeName(MonDoss.Items(i)) = "DistListItem" Then
j = j + 1
strListe = strListe & vbCrLf & j & " - " & MonDoss.Items(i).DLName
tabListes(j) = MonDoss.Items(i).DLName
End If
Next
If strListe <> "" Then
ReDim Preserve tabListes(1 To j)
leNumliste = InputBox("Saisissez un des n° de liste ci-dessous :" &
strListe) 'choix de la liste
If (leNumliste >= LBound(tabListes)) And (leNumliste < > UBound(tabListes)) Then
LeNomListe = tabListes(leNumliste)
If LeNomListe <> "" Then
Set MaListe = MonDoss.Items(LeNomListe) ' travail sur la liste
choisie
' MaListe.Display
For i = 1 To laSel.Count 'parcours des éléments de la sélection
If TypeName(laSel.Item(i)) = "MailItem" Then ' filtre sur les
mailItem
Set leMess = laSel.Item(i)
For Each LeRecip In leMess.Recipients
DéjàDansListe = False
If LeRecip.Type = 1 Or LeRecip.Type = 2 Or LeRecip.Type = 3
Then
For intPos = 1 To MaListe.MemberCount
If LCase(LeRecip.Address) > LCase(MaListe.GetMember(intPos).Address) Then 'vérifie si déjà dans liste
DéjàDansListe = True
Exit For
End If
Next
If Not DéjàDansListe Then
MaListe.AddMember LeRecip 'ajout dans la liste de
distrib

MaListe.Save
End If
End If
Next
End If
Next
MsgBox "Liste mise à jour"
End If
Else
MsgBox "Vous n'avez pas saisi un n° valide"
End If
Else
MsgBox "Pas de Liste de distrib dans ce dossier"
Exit Sub
End If
End Sub

' Fin de AjoutDansDistListe

A+
Isa

Bonjour !
Comme promis, voici déjà une variante de ma macro anti-spam :
C'est une macro qui récupère les destinataires A, CC et CCi (si on est
l'expéditeur, bien sûr !) de messages sélectionnés, et qui renseigne la
Liste de distribution de son choix (si elle existe déjà bien sûr !)

Il suffit de la coller dans le code de ThisOutlookSession, de supprimer les
retours à la ligne générés par Outlook Express, enregistrer, puis revenir
sous environnement Outlook classique.
Ensuite, sélectionner au moins un message et lancer la macro par
Outils/Macro/Macros... ThisOutlookSession.AjoutDansDistListe
(Si vous savez faire, créez un bouton avec la macro dans une barre d'outils
!)

' Macro qui lit les destinataires de messages
' pour les mettre dans une liste de distribution

Sub AjoutDansDistListe()
Dim MonDoss As MAPIFolder
Dim MaListe As DistListItem
Dim MonEsp As NameSpace
Dim LeNomListe As String
Dim leNumliste As Integer
Dim intRep As Integer
Dim monExp As Explorer
Dim laSel As Selection
Dim i As Integer, intPos As Integer
Dim LeRecip As Outlook.Recipient
Dim leMess As MailItem
Dim DéjàDansListe As Boolean


Set monExp = ActiveExplorer
Set MonEsp = GetNamespace("MAPI")
Set laSel = monExp.Selection

If laSel.Count = 0 Then
MsgBox "Pas d'élément sélectionné !"
Exit Sub
End If
MsgBox "Sélectionnez le dossier contenant la liste"
Set MonDoss = MonEsp.PickFolder
If MonDoss Is Nothing Then
MsgBox "Pas de dossier sélectionné"
Exit Sub
ElseIf MonDoss.DefaultItemType <> olContactItem Then
MsgBox "Pas un dossier de type Contacts !"
Exit Sub
End If
Dim strListe As String
Dim j As Integer
ReDim tabListes(1 To MonDoss.Items.Count) As String
For i = 1 To MonDoss.Items.Count ' récup des listes de distrib
If TypeName(MonDoss.Items(i)) = "DistListItem" Then
j = j + 1
strListe = strListe & vbCrLf & j & " - " & MonDoss.Items(i).DLName
tabListes(j) = MonDoss.Items(i).DLName
End If
Next
If strListe <> "" Then
ReDim Preserve tabListes(1 To j)
leNumliste = InputBox("Saisissez un des n° de liste ci-dessous :" &
strListe) 'choix de la liste
If (leNumliste >= LBound(tabListes)) And (leNumliste < > UBound(tabListes)) Then
LeNomListe = tabListes(leNumliste)
If LeNomListe <> "" Then
Set MaListe = MonDoss.Items(LeNomListe) ' travail sur la liste
choisie
' MaListe.Display
For i = 1 To laSel.Count 'parcours des éléments de la sélection
If TypeName(laSel.Item(i)) = "MailItem" Then ' filtre sur les
mailItem
Set leMess = laSel.Item(i)
For Each LeRecip In leMess.Recipients
DéjàDansListe = False
If LeRecip.Type = 1 Or LeRecip.Type = 2 Or LeRecip.Type = 3
Then
For intPos = 1 To MaListe.MemberCount
If LCase(LeRecip.Address) > LCase(MaListe.GetMember(intPos).Address) Then 'vérifie si déjà dans liste
DéjàDansListe = True
Exit For
End If
Next
If Not DéjàDansListe Then
MaListe.AddMember LeRecip 'ajout dans la liste de distrib
MaListe.Save
End If
End If
Next
End If
Next
MsgBox "Liste mise à jour"
End If
Else
MsgBox "Vous n'avez pas saisi un n° valide"
End If
Else
MsgBox "Pas de Liste de distrib dans ce dossier"
Exit Sub
End If
End Sub

' Fin de AjoutDansDistListe

A+
Isa