Extraction active directory dans excel

Soyez le premier à donner votre avis sur cette source.

Vue 29 049 fois - Téléchargée 3 210 fois

Télécharger le projet
Commenter

Description

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
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire Commentaires
apache
15 févr. 2019 à 12:16
Bonjour,

Je n'arrive pas à adapter la réponse de pio_killer pour afficher tous les memberof de tous les utilisateurs..

Pouvez-vous m'aider ?
pio_killer Messages postés 62 Date d'inscription mardi 18 juillet 2006 Statut Membre Dernière intervention 15 avril 2016 13
15 avril 2016 à 11:04
Bonjour,

Apache97233, je te répond avec beaucoup de retard désolé.
J'espère que depuis le temps tu as trouvé la solution.

il suffit de mettre "Memberof" et le résultat est chargé dans la variable que tu auras définie.
Les différent MemberOf sont séparé par des points virgules ; 

Private Sub MemberOf()
    Dim Var_MemberOf As String
    
    Var_MemberOf = GetAdsProp("cn", "DUPON Charles", "memberof", "user")
    
    Cells(1, 1) = Var_MemberOf
    
End Sub
Apache97233
20 févr. 2013 à 13:22
Bonjour,

Je suis débutant en la matière. Grand bravo à l'éditeur du script.

J'aimerais extraire les "Membres de" ayant pour attribut memberOf.

Pouvez vous m'aider ?
ferdhy Messages postés 9 Date d'inscription vendredi 14 avril 2006 Statut Membre Dernière intervention 27 mai 2009
10 août 2012 à 15:34
Merci pour ton code il passe sous Excel 2013, Bravo!
bitshifter Messages postés 61 Date d'inscription mardi 1 février 2005 Statut Membre Dernière intervention 28 mai 2012 1
28 mai 2012 à 16:58
Code utile: j'emballe.

Et surtout, bien commenté. Bravo!
S'inscrire maintenant

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.

Du même auteur (pio_killer)