EXTRACTION ACTIVE DIRECTORY DANS EXCEL

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