ProfileFolder erstellen/verwalten Erstellt ProfileFolder für User, vergibt Rechte auf diese und schreibt die Infos ins AD
Autor:   Michael Gosse	Bewertung:     [ Jetzt bewerten ]	Views:  18.349
www.ech-o-lot.de	System:  WinXP, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 25 Bewertung insgesamt: gut Durchschnittliche Bewertung: 3.6 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Nachfolgender Code erstellt Profilordner für Benutzer. Im ersten Anlauf erstellt es eine Datei "user_profile.xls". Diese Datei sollte nachbearbeitet werden. Das erste Worksheet enthält alle Benutzer aus dem AD. Die Benutzer, denen man keinen ProfilOrdner zuteilen möchte, einfach aus der Tabelle löschen. Danach das Programm wieder starten. Anschließend werden die HomeOrdner gemäß den Angaben erstellt.

Option Explicit
 
' Deklarieren von Variablen und Konstanten
Dim strUser, objDSE, strDefaultDN, strDN, domainname
Dim domainfqdn, path
Dim txt, Logfiletxt, LogFolder, objLOG, objTextFile
Dim objContainer, l, Laufwerk
Dim objExcel, objWorkbook, objWorksheet1, objWorksheet2
Dim USER_ROOT_UNC, USER_ROOT_LOCAL
Dim p, q, r, m, arrgr, arrgr1, MyArray, user, server
Dim errorText, objFSO, Message, D, da, username
 
Const WAIT_ON_RETURN = True
Const HIDE_WINDOW = 0
Const ForAppending = 8
Const ForWriting = 2
Const ForReading = 1

Public Sub Main()
  da = 0
 
  ' Setzen der Default-Domäne oder Eingeben einer anderen
  Set objDSE = GetObject("LDAP://rootDSE")
  strDefaultDN = objDSE.Get("defaultNamingContext")
  strDN = InputBox("Bitte den DN der Domäne eintragen:" & vbCrLf & _
    "(e.g. " & strDefaultDN & ")", , strDefaultDN)
  If strDN = "" Then Exit Sub
 
  Set objContainer = GetObject("LDAP://" & strDN)
 
  domainname = objDSE.Get("defaultnamingcontext")
  domainfqdn = fqdn(domainname)
 
  ' Setzen des Pfades "dort wo das Script liegt"
  path = App.path & IIf(Right$(App.path, 1) <> "\", "\", "")
 
  ' Hier wird geprüft ob Datei user_home.xls schon existiert
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  If Not objFSO.FileExists(path & "user_home.xls") Then
    da = 1
    ' wenn nicht wird die Datei neu erstellt........
    MsgBox "Diese Programm erstellt Homeordner auf einem Server, " & _
      "alle Homeordner werden als versteckte Freigaben erstellt!" & _
      "Freigabeberechtigung: Jeder, Vollzugriff. " & _
      "NTFS: der user , ändern. administratoren, vollzugriff!"
 
    ' Erstellen der user_home.xls
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    objExcel.DisplayAlerts = False
    Set objWorkbook = objExcel.Workbooks.Add
    Set objWorksheet1 = objWorkbook.Worksheets(1)
    Set objWorksheet2 = objWorkbook.Worksheets(2)
    objWorkbook.SaveAs path & "user_home.xls"
    l = 1
    Call ListUsers(objContainer, l)
  Else
    MsgBox " Die Datei " & path & "user_home.xls existiert bereits." & _
      "Homepfade werden erstellt!"
 
    ' Öffnen der Datei user_profile.xls
    ' Hier werden die Ergebnisse reingeschrieben
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    objExcel.DisplayAlerts = False
    Set objWorkbook = objExcel.Workbooks.open(path & "user_home.xls")
    Set objWorksheet1 = objWorkbook.Worksheets(1)
    Set objWorksheet2 = objWorkbook.Worksheets(2)
 
    ' Wo sollen die Homefolder abgelegt werden?
    USER_ROOT_UNC = InputBox("Bitte den UNC Pfad der Freigabe eingeben, " & _
      "wo die Homeverzeichnisse angelegt werden sollen." & _
      "Dieser Pfad muss eine Freigabe sein!" & vbCrLf & _
      "(e.g. " & "\\servername\freigabename$" & ")", , "\\servername\freigabename$")
 
    MyArray = Empty
    arrgr = Empty
    arrgr1 = Empty
    MyArray = Split(USER_ROOT_UNC, "\")
    server = MyArray(2)
 
    ' Lokale Platte des Servers
    USER_ROOT_LOCAL = InputBox("Bitte den lokalen Pfad angeben, " & _
      "wo die Homeverzeichnisse angelegt werden sollen." & _
      "Damit ist der lokale Pfad der eben eingegebenen Freigabe gemeint!" & _
      vbCrLf & "(e.g. " & "D:\home" & ")", , "D:\home")
 
    ' Laufwerksbuchstaben des Homelaufwerks angeben
    Laufwerk = InputBox("Bitte den Laufwerksbuchstaben eingeben der den Usern " & _
      "für das Homelaufwerk zugewiesen werden soll:" & _
      vbCrLf & "(e.g. " & "H" & ")", , "H")
 
    ' Logfile erstellen
    txt = ".txt"
    Logfiletxt = "user_home_log" & txt
    LogFolder = path & Logfiletxt
 
    Set objLOG = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objLOG.OpenTextFile(LogFolder, ForWriting, True)
 
    m = 1
    Do Until objWorksheet1.Cells(m, 1).Value = ""
      ' User aus der Tabelle lesen und den Usernamen nehmen und in Tabelle schreiben
      user = objWorksheet1.Cells(m, 1).Value
      MyArray = Empty
      arrgr = Empty
      arrgr1 = Empty
      MyArray = Split(user, ",")
      p = 0
      r = 0
      q = Len(MyArray(0))
      If InStr(MyArray(0), "CN") Then
        arrgr = Mid(MyArray(0), 4, q)
        objWorksheet2.Cells(m, 1).Value = arrgr
        objExcel.save
        strUser = arrgr
        Call CreateHomeFolder(strUser, USER_ROOT_UNC, USER_ROOT_LOCAL, server)
      End If
      m = m + 1
    Loop
    Call SetHomeFolder(server, Laufwerk)
    objExcel.save
    objExcel.Quit
  End If
 
  ' Programmende
  If da = 1 Then
    objExcel.save
    objExcel.Quit
    MsgBox "Fertig mit dem Einlesen der Benutzer. " & _
      "Bitte bearbeiten Sie die Datei user_home.xls!"
  Else
     MsgBox "Die HomeOrdner wurden erstellt!"
  End If
End Sub

' Unterprogramm um User aufzulisten
Sub ListUsers(objADObject, l)
  Dim objChild, objGroup
  For Each objChild In objADObject
    Select Case objChild.Class
      Case "user"
        On Error Resume Next
        Set objGroup = GetObject("LDAP://" & objChild.Get("distinguishedname"))
        objWorksheet1.Cells(l, 1).Value = objChild.Get("distinguishedname")
        username = objChild.Get("distinguishedname")
        l = l + 1
        If Err.Number <> vbEmpty Then
          errorText = "Fehler!"
          ' Call ErrorHandler(errorText, username)
        ElseIf Err.Number = vbEmpty Then
          errorText = "Erfolg!"
          ' Call ErrorHandler(errorText, username)
        End If
 
      Case "organizationalUnit", "container", "builtinDomain"
        Call ListUsers(objChild, l)
    End Select
  Next
End Sub

' Homefolder basteln
Sub CreateHomeFolder(strUser, USER_ROOT_UNC, USER_ROOT_LOCAL, server)
  Dim WshShell, WshNetwork, objFS, objServer, objShare
 
  On Error Resume Next
  Set WshShell = CreateObject("Wscript.Shell")
  Set WshNetwork = CreateObject("WScript.Network")
  Set objFS = CreateObject("Scripting.FileSystemObject")
  Call objFS.CreateFolder(USER_ROOT_UNC & "\" & strUser & "_home")
 
  ' *********************************** - INFO - ***********************************
  ' Ändert Datei-ACLs (Access Control List) oder zeigt sie an.                    *
  '                                                                               *
  ' CACLS Dateiname [/T] [/E] [/C] [/G Benutzer:Zugriff] [/R Benutzer [...]]      *
  '                 [/P Benutzer:Zugriff [...]] [/D Benutzer [...]]               *
  '   Dateiname            ACLs für angegebene Datei anzeigen.                    *
  '   /T                   ACLs der angegebenen Datei im aktuellen Verzeichnis    *
  '                        und allen Unterverzeichnissen ändern.                  *
  '   /E                   ACL bearbeiten anstatt sie zu ersetzen.                *
  '   /C                   Ändern der ACLs bei Zugriffsverletzung fortsetzen.     *
  '   /G Benutzer:Zugriff  Angegebene Zugriffsarten zulassen.                     *
  '                        Zugriff kann sein: R Lesen                             *
  '                                           W  Schreiben                        *
  '                                           C  Ändern (Schreiben)               *
  '                                           F  Vollzugriff                      *
  '   /R Benutzer          Zugriffsrechte des Benutzers aufheben (gültig mit /E). *
  '   /P Benutzer:Zugriff  Zugriffsrechte des Benutzers ersetzen.                 *
  '                        Zugriff kann sein: N  Kein                             *
  '                                           R  Lesen                            *
  '                                           W  Schreiben                        *
  '                                           C  Ändern (Schreiben)               *
  '                                           F  Vollzugriff                      *
  '    /D Benutzer         Zugriff für Benutzer verweigern.                       *
  ' Platzhalterzeichen (Wildcards) werden für "Dateiname" unterstützt.            *
  ' Mehrere Benutzer können in einem Befehl angegeben werden.                     *
  '                                                                               *
  ' Abkürzungen:                                                                  *
  '    CI - Containervererbung.                                                   *
  '         Der ACE-Eintrag wird von Verzeichnissen geerbt.                       *
  '    OI - Objektvererbung.                                                      *
  '         Der ACE-Eintrag wird von Dateien geerbt.                              *
  '    IO - Nur vererben.                                                         *
  '         Der ACE-Eintrag bezieht sich nicht auf                                *
  '         die aktuelle Datei/das aktuelle Verzeichnis.                          *
  ' ********************************************************************************
 
  Call WshShell.Run("cacls " & USER_ROOT_UNC & "\" & strUser & _
    "_home" & " /e /g Administrator:F", HIDE_WINDOW, WAIT_ON_RETURN)
  Call WshShell.Run("cacls " & USER_ROOT_UNC & "\" & strUser & _
    "_home" & " /e /g " & strUser & ":C", HIDE_WINDOW, WAIT_ON_RETURN)
 
  Set objServer = GetObject("WinNT://" & server & "/LanmanServer")
  Set objShare = objServer.Create("fileshare", strUser & "_home" & "$")
  objShare.path = USER_ROOT_LOCAL & "\" & strUser & "_home"
  objShare.MaxUserCount = -1    ' unlimited number of users
  objShare.SetInfo
  username = strUser
 
  ' Fehlerbehandlung
  If Err.Number <> vbEmpty Then
   errorText = "Fehler!"
   Call ErrorHandler(errorText, username)
  ElseIf Err.Number = vbEmpty Then
    errorText = "Erfolg!"
    Call ErrorHandler(errorText, username)
  End If
 
  Set objShare = Nothing
End Sub

' FQDN Namen herausfinden
Function fqdn(dn)
  Dim dnArray, dnsName, i
  dnArray = Split(dn, ",")
  For i = 0 To UBound(dnArray) - 1
    dnsName = dnsName & Mid(dnArray(i), 4, 30) & "."
  Next
  dnsName = dnsName & Mid(dnArray(UBound(dnArray)), 4, 30)
  fqdn = dnsName
End Function

' Unterprogramm Fehlerbehandlung.
Sub ErrorHandler(errorText, username)
  If Err.Number = "-2147942431" Then
    Err.Description = "Add a domain local group to a global or universal " & _
      "group or a domain local group in another domain. Domain local " & _
      "groups can only be added as members to other domain local groups " & _
      "in the same domain. Add a universal group to a global group. " & _
      "Universal groups can be added to universal and domain local " & _
      "groups, but not global groups."
 
  ElseIf Err.Number = "-2147024894" Then
    Err.Description = "The folder exist on this drive in the share!"
 
  ElseIf Err.Number = "-2147016656" Then
    Err.Description = "This object cannot be found on this server!"
 
  ElseIf Err.Number = "-2147019886" Then
    Err.Description = "The specified object is already on this server!"
 
  ElseIf Err.Number = "424" Then
    Err.Description = "This User Homefolder is already a share on this " & _
      "server, or the user don´t exist!"
 
  ElseIf Err.Number = "0" Then
    Err.Description = "The User Homeefolder is successfully set in the " & _
      "User Profile!"
 
  Else
    Err.Description = "This Error is not specified!"
  End If
 
  objTextFile.WriteLine (errorText & " ; " & Err.Number & " ; " & _
    Err.Description & " ; " & username)
  Err.Clear
End Sub

' Setze Homefolder im AD
Sub SetHomeFolder(server, Laufwerk)
  Dim homeDirectory, objUser, strUser, y, HomePath
  y = 1
  ' so lange aus der Exceldatei einlesen, bis "" Zelle leer ist
  Do Until objWorksheet1.Cells(y, 1).Value = ""
    On Error Resume Next
    Set objUser = GetObject("LDAP://" & objWorksheet1.Cells(y, 1).Value)
    strUser = objWorksheet2.Cells(y, 1).Value
 
    ' Home Directory
    HomePath = "\\" & server & "\" & strUser & "_home" & "$"
    objUser.Put "homeDirectory", HomePath
    objUser.Put "homeDrive", Laufwerk
    username = "\\" & server & "\" & strUser & "_home" & "$"
    objUser.SetInfo
 
    ' Fehlerbehandlung
    If Err.Number <> vbEmpty Then
      errorText = "Fehler!"
      Call ErrorHandler(errorText, username)
    ElseIf Err.Number = vbEmpty Then
      errorText = "Erfolg!"
      Call ErrorHandler(errorText, username)
    End If
    y = y + 1
  Loop
End Sub