Discussion :

[Fredo67]

Bonjour,

je souhaiterais importer dans une table Access l'ensemble des utilisateurs de l'Active Directory.

En cherchant sur le net, je trouve beaucoup de code pour Excel mais rien pour Access.
Quelqu'un pourrait il m'aider ?
D'avance merci

[Jean-Philippe André]

salut
le raisonnement peut être simple si tu pars du fichier excel, et que tu importes le résultat.

As-tu un code sous excel qui t'a plu déjà ?

[Fredo67]

J'ai ce code qui correspond parfaitement à mes attentes.
C'est un script dans Excel qui fonctionne très bien. Je voudrais faire la même chose mais directement depuis Access.

Si quelqu'un peut m'aiguiller ce serait génial

Voici le script qui fonctionne dans Excel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 
 
Dim fso, MyFile, reptemp, filetext
'stroucible = InputBox("renseigner le nom de l'ou cible : ")
' Attention à modifier le nom LDAP du domaine
strDomainDN = "Mon OU masquée volontairement"
' Attention le répertoire c:\temp doit exister
reptemp = "T:\Exploitation\Extraction_AD\"
filetext = "ad_users"
Set fso = CreateObject("Scripting.FileSystemObject")
' création d'un fichier txt pour la première partie du script, soit le nom des utilisateurs
Set MyFile = fso.CreateTextFile(reptemp + filetext + ".txt")
' Ici un filtre sur les utilisateurs et je récupére leur Distinguishedname
strBase = "<LDAP://" & strDomainDN & ">;"
strFilter = "(&(objectclass=user)(objectcategory=person));"
strAttrs = "distinguishedname;"
strScope = "subtree"
Set objConn = CreateObject("ADODB.Connection")
objConn.Provider = "ADsDSOObject"
objConn.Open "Active Directory Provider"
' Ici lancement de la requêtes et écriture dans le fichier txt dans le c:\temp
Set objRS = objConn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst
While Not objRS.EOF
MyFile.WriteLine (objRS.Fields(0).Value)
    objRS.MoveNext
Wend
MyFile.Close
' Maintenant avec le fichier txt je récupère les informations utilisateurs par utilisateurs
On Error Resume Next
Dim objConnection, objRecords, objExcel, strQuery, i, objSpread, intRow
'Attention le fichier C:\sources.xls doit exister
strSheet = "T:\Exploitation\Extraction_AD\Source.xls"
Set objExcel = CreateObject("Excel.Application")
Set objSpread = objExcel.Workbooks.Open(strSheet)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set UserListe = objFSO.OpenTextFile(reptemp + filetext + ".txt")
'Renseigner le numéro de la première ligne Excel ou vous souhaité écrire les inforamations
i = 2
  ' liste des attributs à récupérer
  Do Until UserListe.AtEndofStream
    UserLDAP = UserListe.Readline
    Set objUser = GetObject("LDAP://" & UserLDAP & "")
        CNStr = Left(UserLDAP, InStr(UserLDAP, ",") - 1)
        OuStr = Right(UserLDAP, Len(UserLDAP) - InStr(UserLDAP, ","))
        objExcel.ActiveSheet.Range("A" & i).Value = CNStr
        objExcel.ActiveSheet.Range("B" & i).Value = OuStr
        objExcel.ActiveSheet.Range("C" & i).Value = objUser.givenName
        objExcel.ActiveSheet.Range("D" & i).Value = objUser.initials
        objExcel.ActiveSheet.Range("E" & i).Value = objUser.sn
        objExcel.ActiveSheet.Range("F" & i).Value = objUser.displayName
        objExcel.ActiveSheet.Range("G" & i).Value = objUser.userPrincipalName
        objExcel.ActiveSheet.Range("H" & i).Value = objUser.SamaccountName
        objExcel.ActiveSheet.Range("I" & i).Value = objUser.mail
        objExcel.ActiveSheet.Range("J" & i).Value = objUser.physicalDeliveryOfficeName
        objExcel.ActiveSheet.Range("K" & i).Value = objUser.telephoneNumber
        objExcel.ActiveSheet.Range("L" & i).Value = objUser.Description
        i = i + 1
  Loop
'Sauvegarde du fichier Excel
objExcel.ActiveWorkbook.SaveAs (reptemp + filetext + ".xls")
objExcel.ActiveWorkbook.Close
objExcel.Workbooks.Close
MsgBox "fin de récupération des utilisateurs. Le fichiers excel est dans " + reptemp + filetext + ".xls"
objExcel.Quit
End Sub

[Fredo67]

personne ne peut m'aider ?

[Jean-Philippe André]

salut,
une fois que tu as ton fichier excel, et que sais où il se trouve, tu peux l'importer dans access, voir la commande

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Docmd.TransfertSpreadSheet

[LedZeppII]

Bonjour,

Voici un essai que j'ai fait pour transformer ton code.
Il écrit directement dans la table tblUsers(CN, OU, GivenName, Initials, sn, DisplayName, userPrincipalName, SamAccountName, mail, physicalDeliveryOfficeName, telephoneNumber, Description)
Par contre je n'arrive pas à récupérer plus de 1000 utilisateurs (?).

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub TstGetUsers()
Dim strDomainDN As String
Dim strBase As String, strFilter As String
Dim strAttrs As String, strScope As String
Dim objConn As ADODB.Connection, objRS As ADODB.Recordset
Dim strUserLDAP As String, objUser As Object
Dim strOU As String, strCN As String
Dim accConn As ADODB.Connection, rsUser As ADODB.Recordset
 
'stroucible = InputBox("renseigner le nom de l'ou cible : ")
' Attention à modifier le nom LDAP du domaine
strDomainDN = "XXXX"
 
strBase = "<LDAP://" & strDomainDN & ">;"
strFilter = "(&(objectclass=user)(objectcategory=person));"
strAttrs = "distinguishedname;"
strScope = "subtree"
 
Set objConn = CreateObject("ADODB.Connection")
objConn.Provider = "ADsDSOObject"
objConn.Open "Active Directory Provider"
' Ici lancement de la requête
Set objRS = objConn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst
 
If Not objRS.EOF Then
    DoCmd.RunSQL "DELETE FROM tblUsers"
    Set accConn = New ADODB.Connection
    accConn.ConnectionString = CurrentProject.BaseConnectionString
    accConn.Open
    Set rsUser = New ADODB.Recordset
    Set rsUser.ActiveConnection = accConn
    rsUser.Open "tblUsers", , adOpenKeyset, adLockOptimistic, adCmdTable
 
    While Not objRS.EOF
        strUserLDAP = objRS.Fields(0).Value
        Set objUser = GetObject("LDAP://" & strUserLDAP & "")
 
        strCN = Left(strUserLDAP, InStr(strUserLDAP, ",") - 1)
        strOU = Right(strUserLDAP, Len(strUserLDAP) - InStr(strUserLDAP, ","))
        ' Enregistrement dans table Access
        rsUser.AddNew
        On Error Resume Next
        rsUser!CN = strCN
        rsUser!OU = strOU
        rsUser!givenname = objUser.givenname
        rsUser!initials = objUser.initials
        rsUser!sn = objUser.sn
        rsUser!displayName = objUser.displayName
        rsUser!userPrincipalName = objUser.userPrincipalName
        rsUser!SamaccountName = objUser.SamaccountName
        rsUser!mail = objUser.mail
        rsUser!physicalDeliveryOfficeName = objUser.physicalDeliveryOfficeName
        rsUser!telephoneNumber = objUser.telephoneNumber
        rsUser!Description = objUser.Description
        On Error GoTo 0
        rsUser.Update
 
        objRS.MoveNext
    Wend
    rsUser.Close
    Set rsUser = Nothing
    accConn.Close
    Set accConn = Nothing
End If
 
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
 
End Sub

A+

[Fredo67]

Merci beaucoup pour ta conversion, mais ça plante avec le message suivant :

Erreur d'execution '2147217887 (80040e21)'
Update ou CancelUpdate effectué sans appeler AddNew ni Edit



on doit pas être loin de la solution....

[LedZeppII]

Je crois que j'ai eu ça aussi parce qu'un des champs était trop petit.
Je n'ai pas ma base sous la main, mais je crois que j'ai tout mis à 200 caractères.

[Fredo67]

IMPECCABLE ! ça fonctionne merci !!!!!!!!!!
il fallait effectivement augmenter la taille des champs de ma table users