Discussion :

[inddijoss]

Bonjour à tous,
non développeur mais parfois obligé de fouiller le code pour faire quelques adaptations, j'ai entrepris de mettre à jour notre fichier organigramme XLS de façon automatique depuis l'AD pour éviter les double saisies.

J'ai trouvé un script que j'ai adapté à ma sauce en ajoutant des champs supplémentaires :
------------------------------------------------------------------------------------------

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
Type Type_AD_Extraction
    User_Name As String
    User_Last_Name As String
    User_First_Name As String
    User_City As String
    User_Description As String
    User_Title As String
    User_Mail As String
    User_TelephoneNumber As String
    User_IpPhone As String
    User_Mobile As String
    User_ConfInterne As String
    User_ConfExterne As String
    User_ConfCode As String
    User_Department As String
    User_Initials As String
    User_Company As String
 
End Type
 
Sub Extract_AD_UserName_And_UserLogin()
    '**********************************************************
    'Cette procédure extrait les propriétés
        'Nom prénom et login windows
        'de tous les utilisateur de l'Active Directory
    '**********************************************************
 
    Range("A1").Select
    Dim Tab_Query() As Type_AD_Extraction
    Dim Pos_Tab_Query As Integer
 
    'On définit les variables
    SearchField = "samAccountName"
    SearchString = "*"
    ReturnField = "CN"
    LDAP_objectCategory = "person"
 
    ' Get the domain string ("dc=domain, dc=local")
    Dim strDomain As String
    strDomain = GetObject("LDAP://rootDSE").Get("defaultNamingContext")
 
    ' ADODB Connection to AD
    Dim objConnection As ADODB.Connection
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open "Provider=ADsDSOObject;"
 
    ' Connection
    Dim objCommand As ADODB.Command
    Set objCommand = CreateObject("ADODB.Command")
    objCommand.ActiveConnection = objConnection
 
    ' Search the AD recursively, starting at root of the domain
    objCommand.CommandText = _
        "<LDAP://" & strDomain & ">;(&(objectCategory=" & LDAP_objectCategory & ")" & _
        "(" & SearchField & "=" & SearchString & "));" & SearchField & "," & ReturnField & ";subtree"
    ' RecordSet
    Dim objRecordSet As ADODB.Recordset
    Set objRecordSet = objCommand.Execute
 
    Pos_Tab_Query = 0
    ReDim Tab_Query(Pos_Tab_Query)
    If objRecordSet.RecordCount = 0 Then
        Tab_Query(Pos_Tab_Query).User_Name = "not found"  ' no records returned
    Else
        'On balaye la liste
        Do Until objRecordSet.EOF
            If Tab_Query(Pos_Tab_Query).User_Name <> "" Then
                Pos_Tab_Query = Pos_Tab_Query + 1
                ReDim Preserve Tab_Query(Pos_Tab_Query)
            End If
 
            'On prend le nom complet
            Tab_Query(Pos_Tab_Query).User_Name = objRecordSet.Fields(ReturnField)
 
            'On prend le nom
            Tab_Query(Pos_Tab_Query).User_Last_Name = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "sn", "user")
 
            'On prend le prénom
            Tab_Query(Pos_Tab_Query).User_First_Name = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "givenName", "user")
 
            'On cherche le site
            Tab_Query(Pos_Tab_Query).User_City = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "physicalDeliveryOfficeName", "user")
 
            'On cherche la description pour la fonction interne
            Tab_Query(Pos_Tab_Query).User_Description = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
 
            'On cherche la fonction
            Tab_Query(Pos_Tab_Query).User_Title = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "title", "user")
 
            'On cherche l'adresse mail
            Tab_Query(Pos_Tab_Query).User_Mail = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "mail", "user")
 
            'On cherche le numéro de téléphone
            Tab_Query(Pos_Tab_Query).User_TelephoneNumber = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "telephoneNumber", "user")
 
            'On cherche le numéro interne
            Tab_Query(Pos_Tab_Query).User_IpPhone = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "ipPhone", "user")
 
            'On cherche le numéro de mobile
            Tab_Query(Pos_Tab_Query).User_Mobile = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "mobile", "user")
 
            'On cherche le numéro de conf interne
            Tab_Query(Pos_Tab_Query).User_ConfInterne = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "homePhone", "user")
 
            'On cherche le numéro de conf externe
            Tab_Query(Pos_Tab_Query).User_ConfExterne = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "wWWHomePage", "user")
 
            'On cherche le code de conf
            Tab_Query(Pos_Tab_Query).User_ConfCode = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "pager", "user")
 
            'On cherche le service
            Tab_Query(Pos_Tab_Query).User_Department = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "department", "user")
 
            'On cherche les initiales
            Tab_Query(Pos_Tab_Query).User_Initials = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "initials", "user")
 
            'On cherche la société
            Tab_Query(Pos_Tab_Query).User_Company = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "company", "user")
 
 
            objRecordSet.MoveNext
        Loop
    End If
 
    ' Close connection
    objConnection.Close
 
    ' Cleanup
    Set objRecordSet = Nothing
    Set objCommand = Nothing
    Set objConnection = Nothing
 
    '*********************  Export dans EXCEL  ********************
    'On bloque l'affichage
    Application.ScreenUpdating = False
 
    ligne_Debut = 1
 
    'On supprime tout
    Rows(ligne_Debut).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
 
    'On écrit le résultat
    ligne = ligne_Debut
    Cells(ligne, 1) = "Nom"
    Cells(ligne, 2) = "Prénom"
    Cells(ligne, 3) = "Site"
    Cells(ligne, 4) = "Fonction interne"
    Cells(ligne, 5) = "Fonction externe"
    Cells(ligne, 6) = "Courriel"
    Cells(ligne, 7) = "Ligne directe"
    Cells(ligne, 8) = "N° interne"
    Cells(ligne, 9) = "Mobile"
    Cells(ligne, 10) = "Chambre de conférence audio"
    Cells(ligne, 11) = "Numéro interne chambre conférence audio"
    Cells(ligne, 12) = "Numéro externe chambre conférence audio"
    Cells(ligne, 13) = "Code chambre conférence audio"
    Cells(ligne, 14) = "Service"
    Cells(ligne, 15) = "Initiales"
    Cells(ligne, 16) = "COMPANY"
 
    ligne = ligne + 1
    For Pos_Tab_Query = 0 To UBound(Tab_Query)
        Cells(ligne, 1) = Tab_Query(Pos_Tab_Query).User_Last_Name
        Cells(ligne, 2) = Tab_Query(Pos_Tab_Query).User_First_Name
        Cells(ligne, 3) = Tab_Query(Pos_Tab_Query).User_City
        Cells(ligne, 4) = Tab_Query(Pos_Tab_Query).User_Description
        Cells(ligne, 5) = Tab_Query(Pos_Tab_Query).User_Title
        Cells(ligne, 6) = Tab_Query(Pos_Tab_Query).User_Mail
        Cells(ligne, 7) = Tab_Query(Pos_Tab_Query).User_TelephoneNumber
        Cells(ligne, 8) = Tab_Query(Pos_Tab_Query).User_IpPhone
        Cells(ligne, 9) = Tab_Query(Pos_Tab_Query).User_Mobile
        Cells(ligne, 10) = ""
        Cells(ligne, 11) = Tab_Query(Pos_Tab_Query).User_ConfInterne
        Cells(ligne, 12) = Tab_Query(Pos_Tab_Query).User_ConfExterne
        Cells(ligne, 13) = Tab_Query(Pos_Tab_Query).User_ConfCode
        Cells(ligne, 14) = Tab_Query(Pos_Tab_Query).User_Department
        Cells(ligne, 15) = Tab_Query(Pos_Tab_Query).User_Initials
        Cells(ligne, 16) = Tab_Query(Pos_Tab_Query).User_Company
 
        ligne = ligne + 1
    Next Pos_Tab_Query
 
    'On met en page
    Rows(ligne_Debut).Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
 
    Cells.Select
    Selection.ColumnWidth = 100
    Selection.RowHeight = 100
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    '**************************************************************
 
    MsgBox "Extraction terminée", vbInformation
End Sub
Function GetAdsProp(ByVal SearchField As String, _
    ByVal SearchString As String, _
    ByVal ReturnField As String, _
    ByVal Val_objectCategory As String) As String
        '************************************************************************************
        'Cette fonction fait une requête par rapport au champ renseignés
 
        'Elle peut être lancée individuellement
        'Exemples :
            'Pour connaitre le login d'une personne
                'Var_User_Name = "DUPOND Pierre"
                'Var_Login = GetAdsProp("cn", Var_User_Name, "samAccountName", "user")
            'Pour connaitre le nom et le prénom d'une personne si on a le LOGIN
                'Var_Login = "toto" 'il s'agit du login de connexion Windows
                'Var_User_Name = GetAdsProp("samAccountName", Var_Login, "CN", "person")
        '************************************************************************************
 
        'On Error Resume Next
 
        ' Get the domain string ("dc=domain, dc=local")
        Dim strDomain As String
        strDomain = GetObject("LDAP://rootDSE").Get("defaultNamingContext")
 
        ' ADODB Connection to AD
        Dim objConnection As ADODB.Connection
        Set objConnection = CreateObject("ADODB.Connection")
        objConnection.Open "Provider=ADsDSOObject;"
 
        ' Connection
        Dim objCommand As ADODB.Command
        Set objCommand = CreateObject("ADODB.Command")
        objCommand.ActiveConnection = objConnection
 
        ' Search the AD recursively, starting at root of the domain
        objCommand.CommandText = _
            "<LDAP://" & strDomain & ">;(&(objectCategory=" & Val_objectCategory & ")" & _
            "(" & SearchField & "=" & SearchString & "));" & SearchField & "," & ReturnField & ";subtree"
        ' RecordSet
        Dim objRecordSet As ADODB.Recordset
        Set objRecordSet = objCommand.Execute
 
 
        If objRecordSet.RecordCount = 0 Then
            GetAdsProp = "not found"  ' no records returned
        Else
            If IsNull(objRecordSet.Fields(ReturnField)) = False Then
                GetAdsProp = objRecordSet.Fields(ReturnField)  ' return value
            Else
                GetAdsProp = ""
            End If
        End If
 
        ' Close connection
        objConnection.Close
 
        ' Cleanup
        Set objRecordSet = Nothing
        Set objCommand = Nothing
        Set objConnection = Nothing
End Function

------------------------------------------------------------------------------------------
Tout fonctionnait très bien jusqu'à ce que j'ajoute le champ description.

Message d'erreur reçu :
"Erreur d'exécution 13
Incompatibilité de type"

qui surligne la ligne 259
GetAdsProp = objRecordSet.Fields(ReturnField) ' return value

Il semblerait que le format attribué string n'aille pas à cet attribut...

Je suis tellement ignorant en la matière que je ne vois pas de pistes malgré de nombreuses recherches sur la toile...


D'avance merci pour vos pistes !

[parmi]

Bonjour,

Lorsque tu mets du code utilise le bouton # pour encadrer celui-ci et le rendre plus lisible.
Utilise aussi une certaine indentation pour qu'on s'y retrouve plus aisément.
Et habitue-toi à déclarer tes variables en haut du code de chaque procédure et non pas un peu partout.
Ce sera plus facile pour toi comme pour nous de nous y retrouver...

[parmi]

Comme ta Function retourne une String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Function GetAdsProp(ByVal SearchField As String, _
 ByVal SearchString As String, _
 ByVal ReturnField As String, _
 ByVal Val_objectCategory As String) As String

La ligne qui te pose problème cherche peut-être à retourner un nombre ou autre.
Tu peux changer le type de retour de ta function par As Variant

Ou encore forcer en String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

GetAdsProp = CStr(objRecordSet.Fields(ReturnField)) ' return value

[inddijoss]

Bonjour,
l'indentation n'est manifestement pas passée au copier/coller, toutes mes excuses !

De plus, n'étant pas un pro du code, je suis incapable de créer ce genre de chose et me suis contenté de trouver le code sur la toile et de l'adapter. J'essaierai de faire mieux la prochaine fois !!!

Bonjour,

Lorsque tu mets du code utilise le bouton # pour encadrer celui-ci et le rendre plus lisible.
Utilise aussi une certaine indentation pour qu'on s'y retrouve plus aisément.
Et habitue-toi à déclarer tes variables en haut du code de chaque procédure et non pas un peu partout.
Ce sera plus facile pour toi comme pour nous de nous y retrouver...

[inddijoss]

Un grand merci pour cette réponse à la fois rapide et précise (si tant est que je comprenne tout !)
Je vais tester tout cela !

Comme ta Function retourne une String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Function GetAdsProp(ByVal SearchField As String, _
 ByVal SearchString As String, _
 ByVal ReturnField As String, _
 ByVal Val_objectCategory As String) As String

La ligne qui te pose problème cherche peut-être à retourner un nombre ou autre.
Tu peux changer le type de retour de ta function par As Variant

Ou encore forcer en String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

GetAdsProp = CStr(objRecordSet.Fields(ReturnField)) ' return value

[inddijoss]

Même sanction pour chacune des deux solutions proposées.

Il semble que le format retourné des données du champ description soit particulier...

Je vais chercher de nouveau sur la toile, merci encore pour ton aide Parmi !

Comme ta Function retourne une String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Function GetAdsProp(ByVal SearchField As String, _
 ByVal SearchString As String, _
 ByVal ReturnField As String, _
 ByVal Val_objectCategory As String) As String

La ligne qui te pose problème cherche peut-être à retourner un nombre ou autre.
Tu peux changer le type de retour de ta function par As Variant

Ou encore forcer en String

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

GetAdsProp = CStr(objRecordSet.Fields(ReturnField)) ' return value

[parmi]

Mets un point d'arrêt sur cette ligne (F9) ou attends que l'erreur survienne et choisis Débogage.
Lorsque le processus arrête et que tu te retrouves avec la ligne surlignée en jaune, regarde la valeur des différentes variables en passans ta souris au-dessus de celles-ci.

Dans le menu Affichage de VBA, choisis Fenêtre Espions.
Tu peux sélectionner des variables de ton code et les déplacer dans cette fenêtre et tu pourras voir leurs valeurs au moment où le code s'arrête sur un point d'arrêt.
C'est très pratique pour découvrir des erreurs.

[inddijoss]

Il semble que le format retourné des données du champ description soit particulier...

Lu ici : http://blogs.technet.com/b/heyscript...ry-search.aspx
l'attribut AD description est de type multi-valued et doit être traité en array.

J'ai essayé (je rappelle que je ne suis pas développeur !) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
            'On cherche la description pour la fonction interne
            'Tab_Query(Pos_Tab_Query).User_Description = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
 
            For Each Description In GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user").Value
                Tab_Query(Pos_Tab_Query).User_Description = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
            Next
                objRecordSet.MoveNext
            Loop

et déclaré :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

     User_Description As Variant

mais reçois "Erreur de compilation, qualificateur incorrect"

HTML ou PHP, ça me va, mais là, j'ai du mal !!!

[parmi]

Déclare une variable Retour as Variant
(et GetAdsProp As Variant si ce n'est pas déjà fait)

et change cette partie

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
            'On cherche la description pour la fonction interne
            Retour = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
            For I = 0 To UBound(Retour)
                Tab_Query(Pos_Tab_Query).User_Description = Tab_Query(Pos_Tab_Query).User_Description & Retour(I) & vbCrLf
            Next

En fait, je lis chaque partie retournée et les joins ensemble avec retour de chariot dans la variable User_Description
Tu peux changer le vbCrLf par un espace ou autre selon tes préférences.
EDIT: En fait, il vaudrait mieux utiliser vbLf plutôt que vbCrLf pour eviter un caractère "carré". C'est équivalent au saut de ligne (Alt-Enter) normal.

En fait, ce serait préférable de vérifier si la valeur retournée est belle et bien un Array autrement, on lui donne la valeur telle quelle.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
            'On cherche la description pour la fonction interne
            Retour = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
            If IsArray(Retour) Then
                For I = 0 To UBound(Retour)
                    Tab_Query(Pos_Tab_Query).User_Description = Tab_Query(Pos_Tab_Query).User_Description & Retour(I) & vbLf
                Next
            Else
                Tab_Query(Pos_Tab_Query).User_Description = Retour
            End If

[inddijoss]

En fait, ce serait préférable de vérifier si la valeur retournée est belle et bien un Array autrement, on lui donne la valeur telle quelle.

En fait ce serait préférable que je te remercie infiniment pour avoir su débloquer mon modeste problème ! Un grand bravo et chapeau bas de l'apprenti programmeur au professionnel !


Au cas où cela pourrait être utile à quelqu'un d'autre, le code est ci-dessous (j'en ai pompé 95%, 1% fourni par Parmi, 4% avec l'enregistreur de macro !) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
 
 
Type Type_AD_Extraction
    User_Name As String
    User_Last_Name As String
    User_First_Name As String
    User_City As String
    User_Description As String
    User_Title As String
    User_Mail As String
    User_TelephoneNumber As String
    User_IpPhone As String
    User_Mobile As String
    User_ConfInterne As String
    User_ConfExterne As String
    User_ConfCode As String
    User_Department As String
    User_Initials As String
    User_Addresse As String
    User_postalCode As String
    User_Fax As String
    User_StandardPhone As String
    User_Company As String
    Retour As Variant
 
End Type
 
Sub Extract_AD_UserName_And_UserLogin()
    '**********************************************************
    'Cette procédure extrait les propriétés
        'Nom prénom et login windows
        'de tous les utilisateur de l'Active Directory
    '**********************************************************
 
    Range("A1").Select
    Dim Tab_Query() As Type_AD_Extraction
    Dim Pos_Tab_Query As Integer
 
    'On définit les variables
    SearchField = "samAccountName"
    SearchString = "*"
    ReturnField = "CN"
    LDAP_objectCategory = "person"
 
    ' Get the domain string ("dc=domain, dc=local")
    Dim strDomain As String
    strDomain = GetObject("LDAP://rootDSE").Get("defaultNamingContext")
 
    ' ADODB Connection to AD
    Dim objConnection As ADODB.Connection
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open "Provider=ADsDSOObject;"
 
    ' Connection
    Dim objCommand As ADODB.Command
    Set objCommand = CreateObject("ADODB.Command")
    objCommand.ActiveConnection = objConnection
 
    ' Search the AD recursively, starting at root of the domain
    objCommand.CommandText = _
        "<LDAP://" & strDomain & ">;(&(objectCategory=" & LDAP_objectCategory & ")" & _
        "(" & SearchField & "=" & SearchString & "));" & SearchField & "," & ReturnField & ";subtree"
    ' RecordSet
    Dim objRecordSet As ADODB.Recordset
    Set objRecordSet = objCommand.Execute
 
    Pos_Tab_Query = 0
    ReDim Tab_Query(Pos_Tab_Query)
    If objRecordSet.RecordCount = 0 Then
        Tab_Query(Pos_Tab_Query).User_Name = "not found"  ' no records returned
    Else
        'On balaye la liste
        Do Until objRecordSet.EOF
            If Tab_Query(Pos_Tab_Query).User_Name <> "" Then
                Pos_Tab_Query = Pos_Tab_Query + 1
                ReDim Preserve Tab_Query(Pos_Tab_Query)
            End If
 
            'On prend le nom complet
            Tab_Query(Pos_Tab_Query).User_Name = objRecordSet.Fields(ReturnField)
 
            'On prend le nom
            Tab_Query(Pos_Tab_Query).User_Last_Name = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "sn", "user")
 
            'On prend le prénom
            Tab_Query(Pos_Tab_Query).User_First_Name = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "givenName", "user")
 
            'On cherche le site
            Tab_Query(Pos_Tab_Query).User_City = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "physicalDeliveryOfficeName", "user")
 
            'On cherche la description pour la fonction interne
            Retour = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "description", "user")
            If IsArray(Retour) Then
                For I = 0 To UBound(Retour)
                    Tab_Query(Pos_Tab_Query).User_Description = Tab_Query(Pos_Tab_Query).User_Description & Retour(I) & vbLf
                Next
            Else
                Tab_Query(Pos_Tab_Query).User_Description = Retour
            End If
 
            'On cherche la fonction
            Tab_Query(Pos_Tab_Query).User_Title = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "title", "user")
 
            'On cherche l'adresse mail
            Tab_Query(Pos_Tab_Query).User_Mail = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "mail", "user")
 
            'On cherche le numéro de téléphone
            Tab_Query(Pos_Tab_Query).User_TelephoneNumber = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "telephoneNumber", "user")
 
            'On cherche le numéro interne
            Tab_Query(Pos_Tab_Query).User_IpPhone = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "ipPhone", "user")
 
            'On cherche le numéro de mobile
            Tab_Query(Pos_Tab_Query).User_Mobile = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "mobile", "user")
 
            'On cherche le numéro de conf interne
            Tab_Query(Pos_Tab_Query).User_ConfInterne = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "homePhone", "user")
 
            'On cherche le numéro de conf externe
            Tab_Query(Pos_Tab_Query).User_ConfExterne = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "wWWHomePage", "user")
 
            'On cherche le code de conf
            Tab_Query(Pos_Tab_Query).User_ConfCode = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "pager", "user")
 
            'On cherche le service
            Tab_Query(Pos_Tab_Query).User_Department = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "department", "user")
 
            'On cherche les initiales
            Tab_Query(Pos_Tab_Query).User_Initials = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "initials", "user")
 
            'On cherche l'adresse postale
            Tab_Query(Pos_Tab_Query).User_Addresse = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "streetAddress", "user")
 
            'On cherche le code postal
            Tab_Query(Pos_Tab_Query).User_postalCode = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "postalCode", "user")
 
            'On cherche le fax
            Tab_Query(Pos_Tab_Query).User_Fax = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "facsimileTelephoneNumber", "user")
 
            'On cherche le numéro du standard
            Tab_Query(Pos_Tab_Query).User_StandardPhone = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "st", "user")
 
            'On cherche la société
            Tab_Query(Pos_Tab_Query).User_Company = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "company", "user")
 
 
            objRecordSet.MoveNext
        Loop
    End If
 
    ' Close connection
    objConnection.Close
 
    ' Cleanup
    Set objRecordSet = Nothing
    Set objCommand = Nothing
    Set objConnection = Nothing
 
    '*********************  Export dans EXCEL  ********************
    'On bloque l'affichage
    Application.ScreenUpdating = False
 
    ligne_Debut = 1
 
    'On supprime tout
    Rows(ligne_Debut).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
 
    'On écrit le résultat
    ligne = ligne_Debut
    Cells(ligne, 1) = "Nom"
    Cells(ligne, 2) = "Prénom"
    Cells(ligne, 3) = "Site"
    Cells(ligne, 4) = "Fonction interne"
    Cells(ligne, 5) = "Fonction externe"
    Cells(ligne, 6) = "Courriel"
    Cells(ligne, 7) = "Ligne directe"
    Cells(ligne, 8) = "N° interne"
    Cells(ligne, 9) = "Mobile"
    Cells(ligne, 10) = "Chambre de conférence audio"
    Cells(ligne, 11) = "Numéro interne chambre conférence audio"
    Cells(ligne, 12) = "Numéro externe chambre conférence audio"
    Cells(ligne, 13) = "Code chambre conférence audio"
    Cells(ligne, 14) = "Service"
    Cells(ligne, 15) = "Initiales"
    Cells(ligne, 16) = "Adresse"
    Cells(ligne, 17) = "Code postal"
    Cells(ligne, 18) = "Fax"
    Cells(ligne, 19) = "Standard"
 
    ligne = ligne + 1
    For Pos_Tab_Query = 0 To UBound(Tab_Query)
        Cells(ligne, 1) = Tab_Query(Pos_Tab_Query).User_Last_Name
        Cells(ligne, 2) = Tab_Query(Pos_Tab_Query).User_First_Name
        Cells(ligne, 3) = Tab_Query(Pos_Tab_Query).User_City
        Cells(ligne, 4) = Tab_Query(Pos_Tab_Query).User_Description
        Cells(ligne, 5) = Tab_Query(Pos_Tab_Query).User_Title
        Cells(ligne, 6) = Tab_Query(Pos_Tab_Query).User_Mail
        Cells(ligne, 7) = Tab_Query(Pos_Tab_Query).User_TelephoneNumber
        Cells(ligne, 8) = Tab_Query(Pos_Tab_Query).User_IpPhone
        Cells(ligne, 9) = Tab_Query(Pos_Tab_Query).User_Mobile
        Cells(ligne, 10) = ""
        Cells(ligne, 11) = Tab_Query(Pos_Tab_Query).User_ConfInterne
        Cells(ligne, 12) = Tab_Query(Pos_Tab_Query).User_ConfExterne
        Cells(ligne, 13) = Tab_Query(Pos_Tab_Query).User_ConfCode
        Cells(ligne, 14) = Tab_Query(Pos_Tab_Query).User_Department
        Cells(ligne, 15) = Tab_Query(Pos_Tab_Query).User_Initials
        Cells(ligne, 16) = Tab_Query(Pos_Tab_Query).User_Addresse
        Cells(ligne, 17) = Tab_Query(Pos_Tab_Query).User_postalCode
        Cells(ligne, 18) = Tab_Query(Pos_Tab_Query).User_Fax
        Cells(ligne, 19) = Tab_Query(Pos_Tab_Query).User_StandardPhone
 
        ligne = ligne + 1
    Next Pos_Tab_Query
 
    'On met en page
    Rows(ligne_Debut).Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
 
    Cells.Select
    Selection.ColumnWidth = 100
    Selection.RowHeight = 100
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    '**************************************************************
 
    MsgBox "Extraction terminée", vbInformation
End Sub
Function GetAdsProp(ByVal SearchField As String, _
    ByVal SearchString As String, _
    ByVal ReturnField As String, _
    ByVal Val_objectCategory As String) As Variant
    'ByVal Val_objectCategory As String) As String
        '************************************************************************************
        'Cette fonction fait une requête par rapport au champ renseignés
 
        'Elle peut être lancée individuellement
        'Exemples :
            'Pour connaitre le login d'une personne
                'Var_User_Name = "DUPOND Pierre"
                'Var_Login = GetAdsProp("cn", Var_User_Name, "samAccountName", "user")
            'Pour connaitre le nom et le prénom d'une personne si on a le LOGIN
                'Var_Login = "toto" 'il s'agit du login de connexion Windows
                'Var_User_Name = GetAdsProp("samAccountName", Var_Login, "CN", "person")
        '************************************************************************************
 
        'On Error Resume Next
 
        ' Get the domain string ("dc=domain, dc=local")
        Dim strDomain As String
        strDomain = GetObject("LDAP://rootDSE").Get("defaultNamingContext")
 
        ' ADODB Connection to AD
        Dim objConnection As ADODB.Connection
        Set objConnection = CreateObject("ADODB.Connection")
        objConnection.Open "Provider=ADsDSOObject;"
 
        ' Connection
        Dim objCommand As ADODB.Command
        Set objCommand = CreateObject("ADODB.Command")
        objCommand.ActiveConnection = objConnection
 
        ' Search the AD recursively, starting at root of the domain
        objCommand.CommandText = _
            "<LDAP://" & strDomain & ">;(&(objectCategory=" & Val_objectCategory & ")" & _
            "(" & SearchField & "=" & SearchString & "));" & SearchField & "," & ReturnField & ";subtree"
        ' RecordSet
        Dim objRecordSet As ADODB.Recordset
        Set objRecordSet = objCommand.Execute
 
 
        If objRecordSet.RecordCount = 0 Then
            GetAdsProp = "not found"  ' no records returned
        Else
            If IsNull(objRecordSet.Fields(ReturnField)) = False Then
                GetAdsProp = objRecordSet.Fields(ReturnField)  ' return value
            Else
                GetAdsProp = ""
            End If
        End If
 
        ' Close connection
        objConnection.Close
 
        ' Cleanup
        Set objRecordSet = Nothing
        Set objCommand = Nothing
        Set objConnection = Nothing
End Function
 
Sub Filtrer()
'
' Filtrer Macro
'
    Range("A1").Select
    'sélection d'une plage large
    Range("A1:S1500").Select
    ' filtre automatique
    Selection.AutoFilter
 
    ' tri sur les noms
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Add Key _
        :=Range("A1:A1000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'sélection première ligne sans nom puis jusqu'à 1000
    Range("A1").End(xlDown).Offset(1, 0).Select
    ActiveCell.EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
 
    'suppression des lignes sans nom
    Selection.EntireRow.Delete
 
    'tri sur les prénoms non vides
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Add Key _
        :=Range("B1:B1000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'nettoyage prénoms vides
    Range("B1").End(xlDown).Offset(1, 0).Select
    ActiveCell.EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
 
    'suppression des lignes sans prénom
    Selection.EntireRow.Delete
 
    'tri sur le site non vide
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Add Key _
        :=Range("C1:C1000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'nettoyage sites vides
    Range("C1").End(xlDown).Offset(1, 0).Select
    ActiveCell.EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
 
    'suppression des lignes sans site
    Selection.EntireRow.Delete
 
    ' tri sur les noms
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort.SortFields.Add Key _
        :=Range("A1:A1000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("LDAP_Request").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'positionnement en première cellule, sélection jusqu'à colonne M
    Range("A1").Select
    Range("A1:M1", Range("A1:M1").End(xlDown)).Select
    'définition du nom LDAP_1 pour plage sélectionnée
    ActiveWorkbook.Names.Add Name:="LDAP_1", RefersToR1C1:= _
        "=LDAP_Request!R1C1:R209C13"
 
    'positionnement en cellule N1, sélection jusqu'à colonne S
    Range("N1").Select
    Range("N1:S1", Range("N1:S1").End(xlDown)).Select
    'définition du nom LDAP_2 pour plage sélectionnée
    ActiveWorkbook.Names.Add Name:="LDAP_2", RefersToR1C1:= _
        "=LDAP_Request!R1C14:R220C19"
    Range("A1").Select
 
End Sub