Microsoft 365 VBA : extraire à partir d'excel tous les groupes de contacts d'outlook

[dmc27]

Bonsoir à tous les forumeurs
Outlook (et d'autres sans doute) permettent de créer, pour chaque boîte e-mail, des groupes et des "sous-groupes" de contacts sans duplication de la fiche contact, celle-ci restant dans le groupe principal généralement appelé "contacts". C'est pratique, puisque l'on ne corrige une fiche qu'une fois, et que l'on peut ainsi créer des regroupements par types de contacts ( famille, clients,etc.), précisant qu'un même contact peut ainsi être simultanément dans le sous-groupe famille et dans le sous-groupe clients.
Néanmoins, je n'ai pas trouvé le moyen de savoir, pour chaque contact, dans quels sous-groupes on pouvait le retrouver, ou même de savoir qu'il n'appartenait à aucun de ces sous-groupes.
Mon objectif est donc de développer une application VBA qui réalisera l'extraction des contacts de plusieurs boites e-mail, d'outlook vers Excel, en affectant une feuille Excel pour chaque sous-groupe rencontré. Puis chacune de ces feuilles alimentera dans une feuille principale un tableau pour chaque adresse e-mail ( monmail@moi.fr par exemple), similaire à celui ci-après, dans lequel famille, collègue, client, fournisseur, footballeur (par exemple) sont les sous-groupes de contacts :

contacts de monmail@moi.fr	sous-groupes
	famille​	collègue​	client​	fournisseur​	footballeur​
Dupont Henri	x​		x​
Durand Antoine		x​			x​
Bruel Patrick			x​		x​
Souchon Alain				x​
Voulzy Laurent	x​	x​			x​

Attention, j'ai déjà posté cette question sur le forum "autres applications", je n'ai pas obtenu de réponse.

Merci de m'avoir lu jusque-là ! j'ai tenté de mettre le paquet pour être clair !
Bien entendu, j'attends vos réponses - nombreuses et salvatrices, j'en suis sûr - avec la plus grande impatience. Parce que là, je suis bloqué! Carrément!
Cordialement - DMC

 

[Hasco]

Bonjour,

Voici une grosse partie du travail à vous de vous pencher dessus et compléter ou corriger. Il y a suffisamment de littérature ici ou sur le web pour que vous puissiez vous en sortir.

La macro crée deux tableaux 1 des contacts (feuille contacts ) et 1 de groupes de contacts (feuille Groupe).
Une fois les tableaux créés, la macro insère une fonction excel dans le tableau des contacts pour qu'elle retourne 1 ou 0 suivant que le contact existe ou non dans l'un des groupes.
A vous éventuellement de formater comme vous voulez. Vous trouverez sur le forum des moyens de remplacer des 1 par des 'checkmarks' et ou cacher les zéros.

Le classeur doit au moins contenir une feuille nommée 'Contacts' et une feuille nommée 'Groupes'.
Lancer la macro 'ContactsEtGroupesOutlook'

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : ContactsEtGroupesOutlook
' Discussion: https://www.excel-downloads.com/threads/vba-extraire-a-partir-dexcel-tous-les-groupes-de-contacts-doutlook.20041531/
' Date      : 14/02/2020
' Objet     : Récupérer les contacts et groupe de contacts Outlook
'---------------------------------------------------------------------------------------
'
Sub ContactsEtGroupesOutlook()
    Const olFolderContacts As Long = 10

    '
    '  Objets et autres variables Outlook
    Dim oOutlook As Object       ' Application
    Dim oNameSpace As Object     ' Espace de nom (MAPI)
    Dim Contacts As Object       ' Liste des contacts
    Dim Contact As Object        ' Un contact (ContactItem)
    Dim GrpContacts As Object    ' Un groupe de contacts(DistListItem)
    Dim WasRunning As Boolean    ' L'application tournait-elle avant l'appel de la macro
    '
    '
    Dim tblContacts() As String   ' Tableau des contacts
    Dim tblGroupe() As String     ' Tableau des adresses d'un groupe de contact
    Dim colGroupes As Collection  ' Collection de tblGroupe
    '
    ' Variables de fonctionnement
    Dim cpt1 As Long             ' Compteur de boucle sur liste contacts
    Dim cpt2 As Long             ' Compteur de boucle sur membre de groupe
    '
    ' Objets excel
    Dim wsContacts As Worksheet, wsGroupes As Worksheet
    '
    '---------------------------------------------------------------------------------------
    '
    '     1 - Travail sur Outlook
    '
    '---------------------------------------------------------------------------------------
    '
    ' Tenter d'ouvrir l'application Outlook
    On Error Resume Next
    Set oOutlook = GetObject("Outlook.Application")
    WasRunning = Not oOutlook Is Nothing
    On Error GoTo FIN
    If Not WasRunning Then Set oOutlook = CreateObject("Outlook.Application")
    '
    ' Récupérer le namespace idoine
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    '
    ' Récupérer les contacts du namespace
    Set Contacts = oNameSpace.GetDefaultFolder(olFolderContacts).Items
    '
    ' Boucler sur tous les contacts (groupe ou non)
    For Each Contact In Contacts
        Select Case TypeName(Contact)
        '
        ' Groupe de contacts
        Case "DistListItem"
            Set GrpContacts = Contact
            '
            ' Si premier, créer la collection des groupes
            If colGroupes Is Nothing Then Set colGroupes = New Collection
            '
            ' dimensionner le tableau au nombre de membres du groupe +1
            ReDim tblGroupe(1 To GrpContacts.MemberCount + 1, 1 To 1)
            '
            ' conserver le nom du groupe en indice 1 du tableau
            tblGroupe(1, 1) = GrpContacts.DLName
            '
            ' Parcourrir les membres du groupe et les ajouter au tableau
            For cpt2 = 1 To GrpContacts.MemberCount
                tblGroupe(cpt2 + 1, 1) = GrpContacts.GetMember(cpt2).Address
            Next
            '
            ' Ajouter le tableau à la collection des groupes
            colGroupes.Add tblGroupe
        '
        ' Contact unique
        Case "ContactItem"
            '
            ' Il peut arriver que l'adresse mail ne soit pas renseignée
            If Trim(Contact.Email1Address) <> "" Then
                '
                ' Ajouter le contact au tableau après redimensionnement de ce dernier
                cpt1 = cpt1 + 1
                ReDim Preserve tblContacts(1 To cpt1)
                tblContacts(cpt1) = Trim(Contact.Email1Address)
            End If
        End Select
    Next
    '
    ' Si l'application outlook ne tournait pas avant l'appel de la macro, la quitter proprement
    If Not WasRunning Then oOutlook.Quit
    '
    ' Nettoyer les variables objet Outlook
    Set oNameSpace = Nothing
    Set oOutlook = Nothing
    Set Contacts = Nothing
    '
    '---------------------------------------------------------------------------------------
    '
    '     2 - Retranscription dans les feuilles du classeur
    '
    '---------------------------------------------------------------------------------------
    With ThisWorkbook.Sheets("Groupes")
        .UsedRange.ClearContents
        For cpt1 = 1 To colGroupes.Count
            .Cells(1, cpt1).Resize(UBound(colGroupes.Item(cpt1)), 1) = colGroupes.Item(cpt1)
        Next
        Application.Names.Add "Groupes", .Cells(1, 1).CurrentRegion
    End With

    With ThisWorkbook.Sheets("Contacts")
        .UsedRange.ClearContents
        cpt1 = UBound(tblContacts)
        .Cells(1, 1) = "Contacts"
        .Cells(2, 1).Resize(cpt1, 1) = Application.Transpose(tblContacts)
        '
        ' Ajouter les noms de groupes en entête de tableau
        .Cells(1, 2).Resize(, colGroupes.Count).Value = ThisWorkbook.Sheets("Groupes").Cells(1, 1).Resize(1, colGroupes.Count).Value
        Application.Names.Add "Contacts", .Cells(1, 1).CurrentRegion
        With .Cells(1, 1).CurrentRegion
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .Formula = "=ISNUMBER(MATCH($A2,OFFSET(Groupes,1,COLUMN()-2,,1),0))*1"
            End With
        End With
    End With
    '
    ' C'est f'i fi n'i ni !
FIN:
    If Err.Number <> 0 Then
       MsgBox "Exécution interrompue en raison de l'erreur suivante: " & vbCrLf & vbCrLf & Err.Description, vbExclamation, "Macro 'ContactsEtGroupesOutlook'"
    End If
End Sub

Cordialement

 

[dmc27]

Bonsoir, et un très grand merci pour cette réponse.
J'ai testé, j'ai un plantage à la ligne suivante :
For cpt1 = 1 To colGroupes.Count
.Cells(1, cpt1).Resize(UBound(colGroupes.Item(cpt1)), 1) = colGroupes.Item(cpt1)
Next
précisément la 2eme qui provoque un déroutement sur la routine d'erreur avec variable objet ou variable de bloc with non définie. Je compte plancher là-dessus demain, franchement je n'ai pas le niveau et je vais tatonner.
Mais déjà j'ai eu très belle amorce. merci et bonne soirée.
Cordialement,
DMC

 

[Hasco]

bonjour,

Je n'ai pas cette erreur chez moi. Ces lignes sont imbriquées dans un bloc
With ThisWorkbook.Sheets("Groupes") ... End With
Entre l'entrée du bloc et la ligne concernée vous ne devez pas avoir un autre With....

Pendant vos test remplace la ligne 'On error Goto FIN' par 'On error Goto 0' afin que le débogueur s'arrête sur les bonnes lignes en cas d'erreur. Testez alors les variable en affichant la fenêtre Variables locales.

Petit plus, pour avoir des 'checkmark' au lieu des 1 vous pouvez, remplacer un peu plus loin le bloc With .Cells(1, 1).CurrentRegion ... End With par celui-ci:

With .Cells(1, 1).CurrentRegion
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .Formula = "=ISNUMBER(MATCH($A2,OFFSET(Groupes,1,COLUMN()-2,,1),0))*1"
                .NumberFormat = "ü;;"
                .HorizontalAlignment = xlCenter
                With .Font
                    .Name = "Wingdings"
                    .Size = 16
                End With
            End With
        End With

Cordialement

 

[dmc27]

Bonjour Roblochon
J'ai désactivé la routine d'erreur, le plantage se produit sur la première ligne de la boucle:
For cpt1 = 1 To colGroupes.Count
j'obtiens le même message d'erreur, mais avec le numéro d'erreur 91
Par ailleurs, en pistant le déroulement ligne à ligne, j'ai pu constater que la routine d'extraction ne détecte que ma première adresse e-mail, ne contenant qu'un contact.
Dois-je préciser que mon autre adresse e-mail est une adresse icloud.com? je commence à croire que c'est l'un des problèmes. Il se trouve que c'est sur elle que j'ai mes 1500 contacts, que c'est elle que je partage avec mon smartphone, mon PC fixe, ma tablette Surface, ma collaboratrice, et je partage en plus différents calendriers.
Mais changer ça est plutôt compliqué et fastidieux, il faudrait que j'aie une bonne raison, au-delà du sentiment de ne pas avoir tout compris et maîtrisé.
Qu'en pensez_-vous?
Cordialement.
DMC

 

[dmc27]

Bonjour Roblochon,
Comme beaucoup, je suis confiné… et j'en profite pour avancer sur tout ce que l'on ne prend pas le temps de faire le reste du temps.
Depuis mon dernier message :
- mon pc a totalement planté, j'ai dû en racheter un !
- j'ai basculé mon adresse e-mail principale (mon compte) sur Outlook.fr
- j'ai dupliqué une partie de mes contacts sur ce nouveau compte
Maintenant, avec ma nouvelle configuration, la macro ne plante plus, mais elle ne me renvoie que les contacts du compte Outlook.fr. En revanche, elle me renvoie bien le groupe exemple que j'ai créé, ainsi que les membres de ce groupe. Mais tout cela pour un seul compte, alors que j'ai des contacts sur l'autre compte, en iCloud.
J'aimerais, pour pouvoir avancer, savoir comment accéder à la liste des comptes gérés par l'application Outlook, et pour chacun la liste des dossiers de contacts avec le cas échéant la hiérarchie de ces dossiers.
Dans le même genre, pouvoir énumérer les calendriers de chaque compte et leurs contenus doit être possible.
Comptant sur vos réponses et vous en remerciant .
Cordialement. Bon confinement à tous.
DMC

 

[Hasco]

Bonjour,

Explorer le modèle objet Outlook dépasse le cadre de ce forum (excel) mais vous pouvez aller le consulter par ici. Les exemples sont certes en C# ou en VB mais facilement traduisibles en vba.
L'important étant de toujours savoir dans quel objet ou collection il faut trifouiller ; les objets et collections étant classés sous forme d'arbre hiérarchique.

Une occasion d'apprendre et de faire fructifier un confinement imposé.

Cordialement.

 

[Staple1600]

Bonsoir le fil,

•>Roblochon
Juste pour le plaisir de croiser un confiné qui est loin d'être un con fini
Je me permets ce trait d'humour
(sachant qu'il sera perçu sur le bon registre)

PS: P*tain, imaginez un confinement au temps du Minitel et des serveurs RTC
On n'aurait pas été dans la mouise

 

[dmc27]

confiné ou con fini, in fine je n'ai pas fini… de chercher !
Merci pour ces infos, je suis dessus, mais mon modem entre en surchauffe!
Cordialement
DMC

 

[Hasco]

Bonjour dmc27,
l'ami Staple ,

PS: P*tain, imaginez un confinement au temps du Minitel et des serveurs RTC
On n'aurait pas été dans la mouise

Il y a des fois ou le téléstrat d'Oric me manque. Il suffisait de le connecter sur ce p*tain de Minitel et hop, transformé en serveur en ligne, avec messagerie... Le luxe.

Pauvre Minitel confiné par des confirmés de la rapacité à du "3615 t' es où mon couillon", alors qu'il avait tant à dire. A chacun son convoracevirus

Bonne journée de petits et grands plaisirs confinés