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 |
Question de neophyte : impossibilité de récupérer l'attribut AD description depuis une macro Excel
Répondre avec citation
Partager