Supprimer Liste de diffussion Outlook via VBA Excel

Bonjour,

Je crée une liste de diffusion Outlook avec Excel mais lorsque je change mes données dans Excel et que je relance ma macro, celle-ci me crée une nouvelle liste de diffusion. Et je me retrouve donc avec des doublons.

Je recherche donc à supprimer la liste de diffusion.

Merci pour votre aide car je n'arrive pas à supprimer la liste avant de recréer la nouvelle.

Voici mon code :

Sub CreerListeDiffusion()
'Création de liste de diffusion
Dim OutlookApp As New Outlook.Application
Dim Liste As Outlook.DistListItem
Dim Destinataire As Outlook.Recipient
Dim DateNomListe As String

CetteAnnee = Year(Date)
Les_Mois1 = Month(Date)

If Val(Les_Mois1) > 6 Then
    DateNomListe = CetteAnnee & "/" & CetteAnnee + 1
Else
    DateNomListe = CetteAnnee - 1 & "/" & CetteAnnee
End If

''' Création de la liste Générale '''
i = 1
Ligne = 2

Set Liste = OutlookApp.CreateItem(olDistributionListItem)
Liste.DLName = "Diffusion Générale " & DateNomListe

While i < 76
    If Sheets("Adhérants").Cells(Ligne, 13) <> "email13@exemple.fr" Then
        On Error Resume Next 'Permet si une erreur sur la ligne suivante de passer à l'intruction suivante
        rang = 1 'L'array a 0 pour premier indice
        Set Destinataire = OutlookApp.Session.CreateRecipient(Split(Sheets("Adhérants").Cells(Ligne, 13), " / ")(rang - 1))
        Destinataire.Resolve
        Liste.AddMember Destinataire
        rang = 2 'L'array a 0 pour premier indice
        Set Destinataire = OutlookApp.Session.CreateRecipient(Split(Sheets("Adhérants").Cells(Ligne, 13), " / ")(rang - 1))
        Destinataire.Resolve
        Liste.AddMember Destinataire
        rang = 3 'L'array a 0 pour premier indice
        Set Destinataire = OutlookApp.Session.CreateRecipient(Split(Sheets("Adhérants").Cells(Ligne, 13), " / ")(rang - 1))
        Destinataire.Resolve
        Liste.AddMember Destinataire
        On Error GoTo 0 'Désactive le "On Error Resume Next"

        Ligne = Ligne + 1
        i = i + 1
    Else
        Ligne = Ligne + 1
        i = i + 1
    End If
Wend
Liste.Save

End Sub

Cordialement

Fabien

Bonjour,

Pour ceux que ça peux intéresser j'ai enfin reussie à trouver une solution.

Sub SuppListeDistributionOutlook()

Dim olApp As Outlook.Application
Dim olNmspc As Outlook.Namespace
Dim olAdLst As Outlook.AddressList
Dim olDLst As Outlook.DistListItem

Set olApp = New Outlook.Application
Set olNmspc = olApp.GetNamespace("MAPI")

On Error Resume Next
Set olDLst = olNmspc.GetDefaultFolder(olFolderContacts).Items("NomDeLaListe")
olDLst.Delete
On Error GoTo 0

Set olDLst = Nothing

End Sub

Par contre le nom de la liste de diffussion doit etre ecrit en toute lettre, il ne prend pas les variables dans le nom.

Bonjour,

En fait je voulais mettre un non de liste composé avec une variable et cela ne fonctionner pas.

Mais cela fonctione comme suit :

NameListe = "Diffusion Générale " & DateNomListe
Set olDLst = olNmspc.GetDefaultFolder(olFolderContacts).Items(NameListe)
olDLst.Delete

Bonjour,

Je suis débutant en VBA et je pense que je le resterai car pour moi c'est vraiment un bazar pas possible et trop Microsoft à mon gout... mais ce n'est que mon avis !

Cependant, l'avantage est indéniable pour automatiser les applications Microsoft Office.

J'ai utilisé ton code pour la suppression de liste de distribution. J'ai deux remarques à te faire :

- pour la ligne de code qui ne marche pas avec une variable, essaie la fonction Cstr() qui génère une chaine de caractère.

- au lieu de supprimer la liste de diffusion que tu récupères on pourrait imaginer la compléter avec les nouvelles données. J'ai essayé, ça marche très bien et ça ne doublonne pas les contacts de la liste. Ça permettrait aux utilisateurs de personnaliser leurs listes et s'il faut en réinitialiser on peut toujours en supprimer à la main ou laisser le choix au début du lancement.

Voici mon code :

Sub CreerListeDistribution()

'Il faut activer la référence "Microsoft Outlook Library" Avant de lancer cette macro,
'Dans l'éditeur VBA: Faire Outils>Reference, Cocher "Microsoft Outlook Library"

Dim OutlookApp As New Outlook.Application
Dim olNmspc As Outlook.Namespace
Dim Liste As Outlook.DistListItem
Dim Desti As Outlook.Recipient
Dim ouvert As Boolean
Dim keep As Boolean

Set olNmspc = OutlookApp.GetNamespace("MAPI")

'Question pour la conservation des anciennes données des listes de distribution
keep = True
If MsgBox("Doit-on réinitialiser les listes ?", vbYesNo, "Réinitialisation") = vbYes Then keep = False

'vérification de l'état de Outlook, l'ouvrir s'il est fermé
ouvert = True
If OutlookApp.Explorers.Count = 0 Then
    Call Shell("outlook.exe", 1)
    ouvert = False
End If

'Création de liste de distribution
Dim i As Integer
' j'ai mis un simple bouton sur la Feuil1
' mes données sont en colonne sur la Feuil2 : le nom de chaque liste en première ligne
Sheets("Feuil2").Activate
For i = 1 To 100        ' je me limite à 100 listes
    If Cells(1, i).Value <> "" Then
' on essaye de retrouver la liste de distribution si elle existe
        On Error Resume Next
        Set Liste = olNmspc.GetDefaultFolder(olFolderContacts).Items(CStr(Cells(1, i).Value))
' si on ne veut pas la garder, on la supprime
        If Not keep Then Liste.Delete
' si elle n'existait pas ou si on l'a supprimée, on la crée
        If Liste Is Nothing Or Not keep Then
            Set Liste = OutlookApp.CreateItem(olDistributionListItem)
            Liste.DLName = Cells(1, i).Value
        End If
'remplissage de la liste de diffusion
        For Each c In Range(Cells(2, i), Cells(1000, i))        ' je me limite à 1000 contacts par liste
            If c.Value <> "" Then
                Set Desti = OutlookApp.Session.CreateRecipient(c.Value)
                Desti.Resolve
                On Error Resume Next
                Liste.AddMember Desti
                If Err.Number <> 0 Then
                    MsgBox "on ne peut pas créer les membres de la liste " & CStr(Cells(1, i).Value)
                    GoTo fin
                End If
            End If
        Next c
        Liste.Save
        Set Liste = Nothing
    End If
Next i

fin:
' on remet Outlook dans l'état où il était
If Not ouvert Then OutlookApp.Quit
Set OutlookApp = Nothing

End Sub

Bonjour,

Merci pour les précisions.

Pour la suppression et non la modification c'est un choix car j'ai soit à en ajouter soit à en supprimer et je trouve plus simple (pour mon utilisation) de bâtir la liste à chaque fois au lieu de devoir revenir dessus pour en supprimer.

Et je souhaiter que les actions (cette fonction n'étant qu'une partis des actions faites) se fasse en cliquant une fois, et comme ma listes de contacts contient au maximum 70 adresses cela est rapide et donc peux ce faire à chaque fois.