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 Dieser Tipp wurde bereits 18.349 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevEingabe 3.0 Einfach stark! Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox u.v.m. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |