Utilisation Carnet d'adresse partagé avec VBA [Résolu]

[rstephane]

Bonjour,

Moi j'utilise Outlook 2003 et je souhaiterais utiliser les contacts partagés Outlook avec du VBA. J'ai bien trouvé comment utiliser un carnet d'adresse personnel (via MAPIFOlder) mais pas le carnet d'adresse partagé avec toute l'entreprise :-s

Savez-vous comment procéder?

Merci d'avance,

Stéphane

[Oliv-]

Salut,
Lorsque tu va manuellement dans ce dossier il est où ? dans les "dossiers publics" ?

[rstephane]

Non, pour accéder manuellement à ces contacts je vais dans contact et je clique sur "Ouvrir les contacts partagés...".

[Oliv-]

Donc lorsque tu cliques sur nom... tu obtiens "selectionner un nom"

dans "afficher les noms de " tu as quoi ?

[rstephane]

Oui, c'est ça, dans "Afficher les noms de :" j'ai "Liste d'adresses globale"

[Oliv-]

Salut,
Essaye avec ceci :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Sub ListeElementsConteneur()
'exchange
strNomSite = "SITE"
strNomServeur = "SERVEUR"
Set rootDSE = GetObject("LDAP://" & strNomServeur & "/RootDSE")
contPath = "LDAP://" & strNomServeur & "/" & "CN=Recipients," & "OU=" & strNomSite & "," & rootDSE.get("defaultNamingContext")
Set cont = GetObject(contPath)
cont.Filter = Array("organizationalPerson")
strListeBal = ""
For Each bal In cont
   strListeBal = strListeBal & bal.Name & "-" & bal.Mail & vbCrLf
Next
strListeDl = ""
cont.Filter = Array("groupOfNames")
For Each dl In cont
   strListeDl = strListeDl & dl.Name & vbCrLf
Next
MsgBox "Boîtes aux lettres : " & vbCrLf & strListeBal
MsgBox "Listes de distribution" & vbCrLf & strListeDl
End Sub

[rstephane]

Bonjour Oliv,

Je pense qu'on se rapproche de la solution, mais non, ça ne marche pas :s
Là j'ai remplacé strNomServeur par mon serveur (Je ne sais pas quoi mettre dans strNomSite) mais le code plante en ligne 3 (Set rootDSE =...) ->

Code :

1
2
3
4
5
 
Erreur d'éxécution '-2147016646 (8007203a)':
 
Erreur Automation
Le serveur n'est pas opérationnel

[rstephane]

En fait j'ai cherché dans cette voie et j'ai réussi à faire ce que je voulais :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
monUser = "rstephane"
 
' Connexion
Set objDSE = GetObject("LDAP://rootDSE")
Set oConnection = CreateObject("ADODB.Connection")
oConnection.Provider = "ADsDSOObject"
oConnection.Open "ADs Provider"
 
sFilter = "(&(objectclass=user)(samaccountname=" & monUser & "))"
 
' champ(s) demandé(s)
' -------------------
champs = ";givenName,SN,distinguishedName,userPrincipalName,mail,description"
 
' Niveau de profondeur de recherche dans les OU
' ---------------------------------------------
profondeur = ";subtree"
 
' Construction de la requète
' --------------------------
Requete = "<LDAP://" & objDSE.Get("defaultNamingContext") & ">;" & sFilter & champs & profondeur
 
' execution de la requete
' -----------------------
Set oRecordSet = oConnection.Execute(Requete)
 
nbRecord = oRecordSet.RecordCount
If nbRecord = 0 Then
    MsgBox "Planté !!! Utilisateur " & monUser & " non trouvé"
    oConnection.Close
Else
    MsgBox "Nombre d'enregistrement = " & nbRecord
End If
 
prenom = oRecordSet.Fields("givenName").Value
nom = oRecordSet.Fields("SN").Value
UserDName = oRecordSet.Fields("distinguishedName").Value
UserPName = oRecordSet.Fields("userPrincipalName").Value
Email = oRecordSet.Fields("mail").Value
Description = oRecordSet.Fields("Description").Value
 
' extraction nom OU la plus basse
partie = Split(UserDName, ",")
OU = Right(partie(1), Len(partie(1)) - 3)
 
' Affichage des infos recuperees
' ------------------------------
MsgBox "prenom: " & prenom
MsgBox "nom: " & nom
MsgBox "login: " & login
MsgBox "Email: " & Email
MsgBox "OU: " & OU
 
oConnection.Close

Merci beaucoup pour ton aide Oliv