Cette macro extrait extrait les propriétés "Nom prénom", "login windows", "department", "company", "mail" et "téléphone" de tous les utilisateur de l'Active Directory
Source / Exemple :
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
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.