Synopsis

Je vous présente aujourd’hui un Excel vraiment sympathique que j’avais trouvé sur le net il y a quelques temps, qui permet d’extraire sans droits spécifique la listes des utilisateurs de l’Active Directory via une requête LDAP.

Utilisation

Il suffit de l’ouvrir et de cliquer sur le bouton pour lancer la macro qui va nous sortir une belle liste incluant Nom, Login, Département, Société, Mail et Numéro de Téléphone … rien que ça !

Télécharger le fichier ici …

Ci-dessous la Macro pour les plus expérimentés…

Type Type_AD_Extraction
User_Name As String
User_Login As String
User_Department As String
User_Company As String
User_Mail As String
User_TelephoneNumber 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
'**********************************************************

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
Tab_Query(Pos_Tab_Query).User_Name = objRecordSet.Fields(ReturnField)

'On cherche le login
Tab_Query(Pos_Tab_Query).User_Login = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "samAccountName", "user")

'On cherche le departement
Tab_Query(Pos_Tab_Query).User_Department = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "department", "user")

'On cherche la société
Tab_Query(Pos_Tab_Query).User_Company = GetAdsProp("cn", Tab_Query(Pos_Tab_Query).User_Name, "company", "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")

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 = 5

'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) = "LOGIN"
Cells(ligne, 3) = "DEPARTMENT"
Cells(ligne, 4) = "COMPANY"
Cells(ligne, 5) = "MAIL"
Cells(ligne, 6) = "TELEPHONE"
ligne = ligne + 1
For Pos_Tab_Query = 0 To UBound(Tab_Query)
Cells(ligne, 1) = Tab_Query(Pos_Tab_Query).User_Name
Cells(ligne, 2) = Tab_Query(Pos_Tab_Query).User_Login
Cells(ligne, 3) = Tab_Query(Pos_Tab_Query).User_Department
Cells(ligne, 4) = Tab_Query(Pos_Tab_Query).User_Company
Cells(ligne, 5) = Tab_Query(Pos_Tab_Query).User_Mail
Cells(ligne, 6) = Tab_Query(Pos_Tab_Query).User_TelephoneNumber

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 = 18
.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")
'************************************************************************************

' 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

Source : https://codes-sources.commentcamarche.net/profile/user/pio_killer

1 vote(s)

Loading...