RÉCUPÉRATION DE DONNÉE DE L'ACTIVE DIRECTORY SOUS ACCESS

Option Compare Database
Option Explicit 'plante le programme si une variable n'est pas déclaré
Sub activedir()

'Déclaration des variables
Dim strScope As String, strAttrs As String, strFilter As String, strBase As String, strDomainDN As String
Dim LDAP As String, group As String, login As String, nom As String, mbrf As String
Dim prenom As String, validite As String, expi As String, org As String
Dim tvar() As String
Dim sql As String
Dim mabd As Database
Dim objconn As Object, objRS As Object, objuser As Object
Dim member As Variant

Set mabd = CurrentDb() 'mabd est la base de donnée dans laquel on travaille

strDomainDN = "(le nom de votre domaine)"
strBase = "<LDAP://" & strDomainDN & ">;" 'Définition de l'objet
strFilter = "(&(objectclass=user)(objectcategory=person));" 'Filtre le jeu d'enregistrement afin de garder que les utilisateurs dans l'objet AD
strAttrs = "distinguishedname;" 'Correspond à l'attribut de l'objet que l'on va regarder
strScope = "subtree" 'On pourra rechercher les utilisateurs dans l'arborescence

'Connection à la base
Set objconn = CreateObject("ADODB.Connection") 'Création d'un objet pour la connexion
objconn.Provider = "ADsDSOObject" 'Définition du pilote de connexion
objconn.Open "Active Directory Provider" 'Ouverture de la base

'Validation de la connexion
Set objRS = objconn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst 'Requête d'action sur la recherche.

'Suppression des données existante dans la base.
sql = "delete * from lognames2"
DoCmd.SetWarnings False 'Empêche les fenêtres de confirmation d'apparaitre
DoCmd.RunSQL sql
sql = "delete * from logname_groupe2"
DoCmd.RunSQL sql
sql = "delete * from groupes2"
DoCmd.RunSQL sql
DoCmd.SetWarnings True 'Réactive les fenêtres de confirmation



Do Until objRS.EOF 'Tant que ce ne sera pas le dernier utilisateur trouver la boucle continue
    LDAP = (objRS.Fields(0).Value)  'Obtient le lien LDAP de l'objet trouver
    Set objuser = GetObject("LDAP://" & LDAP & "")

'Les propriétés recherchés de l'objet sont placer dans des variables
    login = (objuser.sAMAccountName)
    prenom = (objuser.givenName)
    nom = (objuser.sn)
    validite = Not (objuser.AccountDisabled)
    expi = objuser.AccountExpirationDate

'Travail dans les données récupérées
    tvar() = Split(LDAP, ",") 'on découpe la variable suivant les virgules et on place chaque morceau dans un tableau
    org = tvar(2) 'on prend la 3 ème case du tableau
    org = Mid(org, 4, Len(org)) ' on découpe les 4 premiers caratères et on place la valeur dans une variable
    If validite = "vrai" Then validite = 1 Else validite = 0 'conversion en donnée numérique
    org = Replace(org, "'", "''") 'on replace les simple quote par de simple quote double, simple quote = erreur
    prenom = Replace(prenom, "'", "''")
    nom = Replace(nom, "'", "''")
    login = Replace(login, "'", "''")
    
    member = objuser.memberof
    On Error Resume Next
    For Each member In objuser.memberof
        tvar() = Split(member, ",")
        mbrf = tvar(0)
        mbrf = Mid(mbrf, 4, Len(mbrf))
        mbrf = Replace(mbrf, "'", "''")

'Insertion des données dans la table logname_groupe2
        sql = "Insert Into logname_groupe2 Values('" & login & "','" & mbrf & "')"
        DoCmd.SetWarnings False
        DoCmd.RunSQL sql
        DoCmd.SetWarnings True
    Next
'Insertion des données dans la table lognames2
    sql = "Insert Into lognames2 Values('" & login & "','" & nom & "','" & prenom & "','" & org & "'," & validite & ",'" & expi & "')"
    DoCmd.SetWarnings False
    DoCmd.RunSQL sql
    DoCmd.SetWarnings True
    objRS.MoveNext
Loop

objRS.MoveFirst

'fin du script pour les utilisateurs et memberof

strFilter = "(&(objectclass=group)(objectcategory=*));" 'Filtre le jeu d'enregistrement
Set objRS = objconn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst 'Requête d'action sur la recherche.

'lancement des recherches et récupération des données dans des variables
Do Until objRS.EOF
    LDAP = (objRS.Fields(0).Value)
    Set objuser = GetObject("LDAP://" & LDAP & "")
    login = (objuser.sAMAccountName)
    
    tvar() = Split(LDAP, ",")
    org = tvar(2)
    org = Mid(org, 4, Len(org))
    org = Replace(org, "'", "''")
    login = Replace(login, "'", "''")
    If org = "groupe" Then org = "global"
    
    sql = "Insert Into groupes2 Values('" & login & "','" & org & "')"
    DoCmd.SetWarnings False
    DoCmd.RunSQL sql
    DoCmd.SetWarnings True
    
    objRS.MoveNext
Loop

'fin du script pour les groupes
mabd.Close
Set objRS = Nothing
Set objconn = Nothing
End Sub