Automatiser l'import de données dans AD

Option Explicit

Dim fso
Dim fichier
Dim Ligne
Dim v
Dim pole, nom, prenom, login, pass, fonction, email
Dim message

Set fso = CreateObject("Scripting.FileSystemObject")

Set fichier = fso.OpenTextFile("users.csv", 1)

Do While Not fichier.AtEndOfStream
  Ligne = fichier.Readline
  v = Split(Ligne, ";")
  Call Cree_Utilisateur(v(0), v(1), v(2), v(3), v(4), v(5), v(6))
Loop

Sub Cree_Utilisateur(pole, nom, prenom, login, pass, fonction, email)

  Dim Domaine
  Domaine = ",DC=Domaine,DC=Local"
 
  ' Construction de l'unité organisationnelle
  Dim nomOU
  nomOU = "OU=" & pole & ",OU=Personnels" & Domaine

  Dim tmp
  tmp = nomOU
  Call CreeOU(tmp, Domaine)
  
  Dim OU
  Set OU = GetObject("LDAP://" & nomOU)
  
  OU.Filter = Array("user")
  Dim existe, element
  
  For Each element In OU
    Dim test
    test = "CN=" & prenom & " " & nom
    MsgBox element.Name & " " & test
    If element.Name = test Then
      existe = 1
      MsgBox "Existe"
      
    End If
  Next

  If existe = 0 Then
    ' Crée l'utilisateur dans l'OU
    Dim User
    Set User = OU.Create("user", "CN=" & prenom & " " & nom)
    
    'Définit le nom d'ouverture de session
    User.Put "SAMAccountName", login
    User.SetInfo
    
    ' Nom d'ouverture de session
    User.Put "userPrincipalName", login
    ' Nom d'usage
    User.Put "sn", nom
    ' Prénom
    User.Put "givenName", prenom
    ' Nom affiché
    User.Put "displayName", prenom & " " & nom
    ' Script de connexion
    User.Put "scriptpath", "script.bat"
    ' Home Directory
    User.Put "homedirectory", "\\SERVEUR\" & login & "$"
    User.SetInfo
    
    ' Adresse Email
    If email <> "" Then
      User.Put "mail", email
    End If
    ' Description
    User.Put "description", fonction
    User.SetInfo
    ' Active le compte
    User.AccountDisabled = False
    User.SetInfo
    
    ' Crée le dossier utilisateur
    Call CreeDossier("Utilisateurs\Personnels\" & pole & "\" & login & "$")
    
    ' Partage le dossier
    Dim ServeurFichiers
    Dim Partage
    Set ServeurFichiers = GetObject("WinNT://Domaine/SERVEUR/Lanmanserver")
    Dim PartageCache
    PartageCache = login & "$"
    MsgBox PartageCache
    Set Partage = ServeurFichiers.Create("fileshare", PartageCache)
    Partage.Path = "C:\Utilisateurs\Personnels\" & pole & "\" & login & "$"
    Partage.SetInfo
    
    ' Définit le mot de passe
    Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
    Const ADS_UF_PASSWD_CANT_CHANGE = &H40
    Set User = GetObject("WinNT://Domaine/" & login)
    User.SetPassword pass
    User.Put "userFlags", User.Get("UserFlags") Or ADS_UF_PASSWD_CANT_CHANGE
    User.Put "userFlags", User.Get("UserFlags") Or ADS_UF_DONT_EXPIRE_PASSWD
    User.SetInfo

    ' Ajoute l'utilisateur au groupe
    Dim LeGroupe
    Set LeGroupe = GetObject("LDAP://CN=" & pole & ", " & nomOU)
    LeGroupe.Add "LDAP://CN=" & prenom & " " & nom & ", " & nomOU
    LeGroupe.SetInfo

  End If
End Sub

Sub CreeOU(chemin, DOM)

  chemin = Left(chemin, Len(chemin) - Len(DOM))
  Dim Toutes
  Toutes = Split(chemin, ",")
  Dim combien, element, adspath, i
  For Each element In Toutes
    combien = combien + 1
  Next
  DOM = Right(DOM, Len(DOM) - 1)
  adspath = DOM
  For i = combien - 1 To 0 Step -1
    ' Vérifie si l'élément existe
    Dim obj
    Set obj = GetObject("LDAP://" & adspath)
    obj.Filter = Array("organizationalUnit")
    Dim item, existe
    existe = 0
    For Each item In obj
      If item.Name = Toutes(i) Then
        existe = 1
      End If
    Next
    If existe = 0 Then
      ' Creation de l'OU
      Dim NewOU
      Set NewOU = obj.Create("organizationalUnit", Toutes(i))
      NewOU.SetInfo

      ' Création du groupe dans l'OU Créée
      
      Dim NouveauGroupe, NomGroupe, temp
      NomGroupe = Right(Toutes(i), Len(Toutes(i) - 3))
      temp = Split(adspath, ",")
      NomGroupe = NomGroupe & " " & Right(temp(0), Len(temp(0)) - 3)
      Set NouveauGroupe = NewOU.Create("group", "CN=" & NomGroupe)
      NouveauGroupe.SetInfo
    End If
    
    adspath = Toutes(i) & "," & adspath
  Next
  
End Sub

Sub CreeDossier(chemin)

    Dim dossiers, racine, repertoire, fso
    dossiers = Split(chemin, "\")
    racine = "C:\"
    For Each repertoire In dossiers
        Set fso = CreateObject("Scripting.filesystemobject")
        If Not fso.folderexists(racine & repertoire) Then
            fso.createfolder racine & repertoire
        End If
        racine = racine & repertoire & "\"
    Next

End Sub