VBScript für automatische User Erstellung im AD

Option Explicit

Private Const ExcelFile = "E:\Test\User.xls"   '###Pfad anpassen  
Private Const ExcelStart = 2                   'Zeile mit dem 1. Eintrag  

Private Const LogFile = "E:\Test\User.Log"     '###Pfad anpassen  

Private Const AccountLength = 7                'Anzahl Zeichen Benutzername  

Private Const xlUp = &HFFFFEFBE                'Konstante: Excel  
Private Const ADS_SCOPE_SUBTREE = 2            'Konstante: ADO-Recordset  

Private Const MsgErr1 = "Datenimport vom ADS fehlgeschlagen!"  
Private Const MsgErr2 = "Datemimport aus Excel-Datei fehlgeschlagen!"  

Private Const LogErr1 = "Benutzername erstellen"  
Private Const LogErr2 = "User dem ADS hinzufügen"  
Private Const LogErr3 = "HomeDir/Profile-Verzeichnis erstellen"  
Private Const LogErr4 = "HomeDir/Profile-Berechtigungen erstellen"  


Private oUserCon, oUserRec, oUserList, oUser, aDaten, sLogMsg, iCountADS1, iCountADS2, iCountExcel


'Main Beg  

    'ADS-Daten einlesen  
    If OpenUserRec = False Then
        MsgBox MsgErr1, vbExclamation, "Fehler...":  WScript.Quit  
    End If
    
    'Assoziatives Array für neue User-Daten  
    Set oUserList = CreateObject("Scripting.Dictionary")  
    
    'Excel-Daten einlesen und neue User im ADS anlegen  
    If GetUserDaten = False Then
        MsgBox MsgErr2, vbExclamation, "Fehler...":  
    Else
        For Each oUser In oUserList.Items
            aDaten = Split(oUser, ";")  
            Call CreateNewUser(aDaten(0), aDaten(1), aDaten(2), aDaten(3), aDaten(4))
        Next                  'Nachname   Vorname    Passwort   Pers-Nr.   Benutzer  
    End If
    
    If oUserCon.State Then oUserCon.Close
    
    Call WriteLogFile(LogFile)

    MsgBox "Fertig!", vbInformation, "Hinweis...":  

'Main End  

'Diese Function Liest die User-Daten aus dem ADS in einen Recordset (ungetestet)  

Private Function OpenUserRec()
    Dim oUserCom
    
    On Error Resume Next
    
    Set oUserCon = CreateObject("ADODB.Connection")  
    Set oUserCom = CreateObject("ADODB.Command")  
    
    oUserCon.Provider = "ADsDSOObject"  
    oUserCon.Open "Active Directory Provider"  
    
    Set oUserCom.ActiveConnection = oUserCon
    
    oUserCom.Properties("Page Size") = 1000  
    oUserCom.Properties("Searchscope") = ADS_SCOPE_SUBTREE  
    
    '#########Entsprechend anpassen  
    oUserCom.CommandText = "SELECT * FROM 'LDAP://DC=Test,DC=DOMAIN,DC=DE' WHERE ObjectCategory='user'"  
        
    Set oUserRec = oUserCom.Execute
    
    If Err Then
        OpenUserRec = False        
        If oUserCon.State Then oUserCon.Close
    Else
        OpenUserRec = True
        iCountADS1 = oUserRec.RecordCount:  iCountADS2 = iCountADS1 
    End If
End Function

'Diese Funktion liest die User-Excel-Datei aus und füllt das Array oUserList mit neuen Usern.  
'UserList(Values):  Nachname;Vorname;Passwort;Pers-Nr;Benutzername  
'Die Spalte Benutzernamen hat dabei keine Relevanz, sie wird nur zu Infozwecken mit abgeglichen.  

Private Function GetUserDaten()
    Dim oExcelApp, oExcelSheet, aToken, sKey, sItem, sBenutzer, i
    
    GetUserDaten = False
    
    On Error Resume Next
    
    Set oExcelApp = CreateObject("Excel.Application")  
    
    With oExcelApp.Workbooks.Open(ExcelFile)
        If Err Then oExcelApp.Quit:  Exit Function

        On Error Goto 0
        
        With .Sheets(1)
            For i = ExcelStart To .Cells(.Rows.Count, "A").End(xlUp).Row  
                If .Cells(i, 1).Text <> "" Then  
                    iCountExcel = iCountExcel + 1
                   
                   '1:Nachname,2:Vorname,3:Passwort,4:Pers-Nr.  
                    aToken = .Cells(i, 1).Resize(1, 4).Value
                    
                    sBenutzer = GetAccountName(aToken(1, 2), aToken(1, 1))
                    
                   .Cells(i, 5) = sBenutzer
                    
                    If sBenutzer = "" Then  
                            Call SetLogMsg(aToken(1, 2), aToken(1, 1), "")  
                            Call SetLogErr(LogErr1)
                    ElseIf TestAccountName(sBenutzer) = False Then
                        sItem = Array(aToken(1, 1), aToken(1, 2), aToken(1, 3), aToken(1, 4), sBenutzer)
                        oUserList.Add "$" & oUserList.Count + 1, Join(sItem, ";")  
                    End If
                End If
            Next
        End With
       .Save
       .Close False
    End With

    oExcelApp.Quit:  GetUserDaten = True
End Function

'Mit dieser Funktion werden dem AD neue User hinzugefügt (ungetestet)  
'Der File-Server wird anhand des 1. Buchstabens des Benutzernamens zugeordent.  

Private Sub CreateNewUser(ByRef sNachname, ByRef sVorname, ByRef sPasswort, ByRef sPersNr, sBenutzer)
    Dim oOU, sFileServer, sCmd1, sCmd2, sErrMsg, iResult, i
    
    On Error Resume Next
    
    Select Case LCase(Left(sBenutzer, 1))
        Case "a", "b", "c", "d", "e"  
            sFileServer = "HomeDirSrv01"  
        Case "f", "g", "h", "i", "j"  
            sFileServer = "HomeDirSrv02"  
        Case "k", "l", "m", "n", "o", "p", "q", "r"  
            sFileServer = "HomeDirSrv03"  
        Case Else
            sFileServer = "HomeDirSrv04"  
    End Select
    
    Call SetLogMsg(sVorname, sNachname, sBenutzer)
   
    '#########Entsprechend anpassen  
    Set oOU = GetObject("LDAP://OU=Test,DC=DOMAIN,DC=DE")  
        
    With oOU.Create("user", "CN=" & sBenutzer)  
        .Put "sAMAccountName", sBenutzer  
        .Put "givenName", sVorname  
        .Put "sn", sNachname  
        .Put "displayName", sNachname & " " & sVorname  
        .Put "profilePath", "\\Server1\Profiles$\" & sBenutzer  
        .Put "homeDirectory", "\\" & sFileServer & "\Homedirectory$\" & sBenutzer  
        .Put "homeDrive", "P:"  
        .Put "employeeID", sPersNr  
        .Put "scriptPath", "login.bat"  
        .SetInfo
        .SetPassword sPasswort
        .AccountDisabled = False
        .SetInfo
    End With
        
    If Err Then Call SetLogErr(LogErr2):  Exit Sub
    
    iCountADS2 = iCountADS2 + 1
    
    WScript.Sleep (1000)    '???  
        
    With CreateObject("Scripting.FilesystemObject")  
        .CreateFolder ("\\" & sFileServer & "\HomeDirectory\" & sBenutzer)  
        .CreateFolder ("\\Server02\Profiles\" & sBenutzer)  
    End With
        
    If Err Then Call SetLogErr(LogErr3):  Exit Sub
    
    sCmd1 = "cacls ""\\" & sFileServer & "\HomeDirectory\" & sBenutzer & """ /t /e /c /g " & _  
            "Domain\Domänen-Admins:F Domain\" & sBenutzer & ":C"  
        
    sCmd2 = "cacls ""\\Server02\Profiles\" & sBenutzer & """ /t /e /c /g " & _  
            "Domain\Domänen-Admins:F Domain\" & sBenutzer & ":C"  

    With CreateObject("WScript.Shell")  
        If .Run(sCmd1, 0, True) Then Err.Raise -1
        If .Run(sCmd2, 0, True) Then Err.Raise -1
    End With
    
    If Err Then Call SetLogErr(LogErr4)
 End Sub

'Diese Funktion prüft, ob der Benutzername im ADS existiert. Rückgabe: True/False  

Private Function TestAccountName(ByRef sBenutzer)
    TestAccountName = False
    
    With oUserRec
        If sBenutzer <> "" And .EOF = False Then  
            .MoveFirst
            .Find = "sAMAccountName = '" & sBenutzer & "'"  
             If Not .EOF Then TestAccountName = True
        End If
    End With
End Function

'Diese Funktion gibt den Benutzernamen des User's aus dem ADS zurück oder erstellt einen neuen  
'Benutzernamen unter Berücksichtigung folgender Kriterien:  

'Umlaute werden ersetzt z.B. 'ü' durch 'ue'...  
'Der Benutzername hat eine maximale Länge, die durch die Konstante 'AccountLength' definiert ist.  
'Der Nachname hat dabei eine maximale Länge von AccountLength -1 und der Vorname eine Länge von 1.  
'Existiert ein Benutzername bereits, dann wird dem Nachnamen eine Ziffern zwischen 1-9 angefügt.  
'Beispiele mit den Namen: 'Müller Anton', Müller Andrea', 'Dorn Beni', 'Müller Anton', 'Dorn Boris'  
'Ergebnis: 'MuelleA', 'Muell1A', 'DornB', 'Muell2A', 'Dorn1B'  

Private Function GetAccountName(ByRef sVorname, ByRef sNachname)
    Dim aUml, sBenutzer, sV, sN, i
    
    sBenutzer = ""  
    
    With oUserRec
        If sVorname <> "" And sNachname <> "" And .EOF = False Then  
           .Sort = "SN"  
           .MoveFirst
            Do Until .EOF
           .Find = "SN = '" & sNachname & "'"  
                If Not .EOF Then
                    If LCase(.Fields("GivenName")) = LCase(sVorname) Then  
                        sBenutzer = .Fields("sAMAccountName"): Exit Do  
                    End If
                   .MoveNext
                End If
            Loop
        End If
    End With

    If sBenutzer = "" Then  
        aUml = Array("ä", "ae", "Ä", "Ae", "ö", "oe", "Ö", "Oe", "ü", "ue", "Ü", "Ue")  
    
        sV = sVorname:   sN = sNachname
        
        For i = 0 To UBound(aUml) Step 2
            sV = Replace(sV, aUml(i), aUml(i + 1))
            sN = Replace(sN, aUml(i), aUml(i + 1))
        Next
        
        sV = Left(sV, 1):  sN = Left(sN, AccountLength - 1):  sBenutzer = sN & sV
        
        If TestAccountName(sBenutzer) Then
            For i = 1 To 9
                sBenutzer = Left(sN, AccountLength - 2) & i & sV
                If TestAccountName(sBenutzer) Then sBenutzer = "" Else Exit For  
            Next
        End If
    End If
        
    GetAccountName = sBenutzer
End Function

'Diese Funktion fügt dem Log-Text eine Zeile mit dem Usernamen... hinzu  

Private Sub SetLogMsg(ByRef sMsg1, sMsg2, sMsg3)
    sLogMsg = sLogMsg & vbCrLf & "User:  " & sMsg1 & ", " & sMsg2 & ", " & sMsg3 & vbCrLf  
End Sub

'Diese Funktion fügt dem Log-Text eine Zeile mit einer Fehlermeldung hinzu  

Private Sub SetLogErr(ByRef sErr)
    sLogMsg = sLogMsg & Space(13) & sErr & " fehlgeschlagen...  " & vbCrLf  
End Sub

'Diese Funktion schreibt den Log-Text in die Log-Datei (LogFile)  

Private Sub WriteLogFile(ByRef sFile)
    Dim oFso, sHead
    
    sHead = vbCrLf & "Erstellt am:" & Space(12) & Now & vbCrLf & vbCrLf & vbCrLf & "User Gesamt:" _  
                   & Space(8) & "ADS davor:  " & iCountADS1 & Space(8) & "ADS danach:  " _  
                   & iCountADS2 & Space(8) & "Excel-Datei:  " & iCountExcel & vbCrLf & vbCrLf  
    
    Set oFso = CreateObject("Scripting.FileSystemObject")  
    
    With oFso.CreateTextFile(sFile)
        .Write sHead & sLogMsg
        .Close
    End With
End Sub

    If Err Then
        If oUserCon.State Then oUserCon.Close
        OpenUserRec = False
    Else
        OpenUserRec = True
    End If

    If Err Then
        If oUserCon.State Then oUserCon.Close
        OpenUserRec = False
    Else
        iCountADS1 = oUserRec.RecordCount:  iCountADS2 = iCountADS1
        OpenUserRec = True
    End If

 .Save
 .Close False

cscript user.vbs>D:\Log.txt

Private Function GetAccountName(ByRef sVorname, ByRef sNachname)
    Dim aUml, sBenutzer, sV, sN, i
    
    sBenutzer = ""  
    
    With oUserRec
        If sVorname <> "" And sNachname <> "" And .EOF = False Then  
           .Sort = "SN"  
           .MoveFirst
            Do Until .EOF
           .Find = "SN = '" & sNachname & "'"  
                If Not .EOF Then
                    If LCase(.Fields("GivenName")) = LCase(sVorname) Then  
                        sBenutzer = .Fields("sAMAccountName"): Exit Do  
                    End If
                   .MoveNext
                End If
            Loop
        End If
    End With

    If sBenutzer = "" Then  
        aUml = Array("ä", "ae", "Ä", "Ae", "ö", "oe", "Ö", "Oe", "ü", "ue", "Ü", "Ue")  
    
        sV = sVorname:   sN = sNachname
        
        For i = 0 To UBound(aUml) Step 2
            sV = Replace(sV, aUml(i), aUml(i + 1))
            sN = Replace(sN, aUml(i), aUml(i + 1))
        Next
        
        sBenutzer = Left(Left(sN, AccountLength - 1) & sV, AccountLength)
        
        If TestAccountName(sBenutzer) Then
            For i = 1 To 9
                sBenutzer = Left(Left(sN, AccountLength - 2) & i & sV, AccountLength)
                If TestAccountName(sBenutzer) Then sBenutzer = "" Else Exit For  
            Next
        End If
    End If
        
    GetAccountName = sBenutzer
End Function

        If Err Then oExcelApp.Quit:  Exit Function

        If Err Then oExcelApp.Quit:  Exit Function
        
        On Error GoTo 0	

'Diese Funktion prüft, ob der Benutzername im ADS existiert. Rückgabe: True/False  

Private Function TestAccountName(ByRef sBenutzer)
    TestAccountName = False
    
    With oUserRec
        If sBenutzer <> "" And .EOF = False Then  
            .MoveFirst
            .Find = "sAMAccountName = '" & sBenutzer & "'"  
             If Not .EOF Then TestAccountName = True
        End If
    End With
End Function

Option Explicit

Private Const ExcelFile = "E:\Test\User.xls"  
Private Const ExcelStart = 2            'Zeile mit dem 1. Eintrag  

Private Const LogFile = "E:\Test\User.Log"  

Private Const AccountLength = 7         'Anzahl Zeichen für Benutzername  

Private Const xlUp = &HFFFFEFBE         'Konstante: Excel  
Private Const ADS_SCOPE_SUBTREE = 2     'Konstante: ADO-Recordset  

Private Const MsgErr1 = "Datenimport vom ADS fehlgeschlagen!"  
Private Const MsgErr2 = "Datemimport aus Excel-Datei fehlgeschlagen!"  

Private Const LogErr1 = "Benutzername erstellen"  
Private Const LogErr2 = "User dem ADS hinzufügen"  
Private Const LogErr3 = "HomeDir/Profile-Verzeichnis erstellen"  
Private Const LogErr4 = "HomeDir/Profile-Berechtigungen erstellen"  

Private oUserList, oNewUserList, oUser, aDaten, sLogMsg, iCountADS1, iCountADS2, iCountExcel


'Main Beg  

    'Assoziatives Arrays für User-Daten  
    Set oUserList = CreateObject("Scripting.Dictionary")    'User-Bestand  
    Set oNewUserList = CreateObject("Scripting.Dictionary") 'User-Neu hinzufügen  
    
    'ADS-Daten einlesen  
    If OpenUserRec = False Then
        MsgBox MsgErr1, vbExclamation, "Fehler...":  WScript.Quit  
    End If
    
    'Excel-Daten einlesen und neue User im ADS anlegen  
    If GetUserDaten = False Then
        MsgBox MsgErr2, vbExclamation, "Fehler...":  WScript.Quit  
    Else
        For Each oUser In oNewUserList.Items
            aDaten = Split(oUser, ";")  
            Call CreateNewUser(aDaten(0), aDaten(1), aDaten(2), aDaten(3), aDaten(4))
        Next                  'Nachname   Vorname    Passwort   Pers-Nr.   Benutzer  
    End If
    
    Call WriteLogFile(LogFile)
    
    Set oUserList = Nothing
    Set oNewUserList = Nothing

'Main End  


'Diese Function Liest die User-Daten aus dem ADS in einen Recordset (ungetestet)  

Private Function OpenUserRec()
    Dim oUserCon, oUserCom, oUserRec
    
    On Error Resume Next
    
    Set oUserCon = CreateObject("ADODB.Connection")  
    Set oUserCom = CreateObject("ADODB.Command")  
    
    oUserCon.Provider = "ADsDSOObject"  
    oUserCon.Open "Active Directory Provider"  
    
    Set oUserCom.ActiveConnection = oUserCon
    
    oUserCom.Properties("Page Size") = 1000  
    oUserCom.Properties("Searchscope") = ADS_SCOPE_SUBTREE  
    
    '#########Entsprechend anpassen  
    oUserCom.CommandText = "SELECT * FROM 'LDAP://DC=Test,DC=DOMAIN,DC=DE' WHERE ObjectCategory='user'"  
        
    Set oUserRec = oUserCom.Execute
    
    If Err Then
        OpenUserRec = False
    Else
        OpenUserRec = True

        With oUserRec
            If .RecordCount Then
               .Sort = "sAMAccountName"  
               .MoveFirst
                Do Until .EOF
                    oUserList.Add .Fields("sAMAccountName").Value, _  
                                  .Fields("SN").Value & ";" & .Fields("GivenName").Value  
                   .MoveNext
                Loop
            End If
        End With
        
        iCountADS1 = oUserList.Count:   iCountADS2 = iCountADS1
    End If
    
    If oUserCon.State Then oUserRec.Close:  oUserCon.Close
End Function

'Diese Funktion liest die User-Excel-Datei aus und füllt das Array oNewUserList mit neuen Usern.  
'NewUserList(Values):  Nachname;Vorname;Passwort;Pers-Nr;Benutzername  
'Die Spalte Benutzernamen hat dabei keine Relevanz, sie wird nur zu Infozwecken mit abgeglichen.  

Private Function GetUserDaten()
    Dim oExcelApp, oExcelSheet, aToken, sKey, sItem, sBenutzer, i
    
    GetUserDaten = False
    
    On Error Resume Next
    
    Set oExcelApp = CreateObject("Excel.Application")  
    
    With oExcelApp.Workbooks.Open(ExcelFile)
        If Err Then oExcelApp.Quit:  Exit Function
        
        On Error GoTo 0
        
        With .Sheets(1)
            For i = ExcelStart To .Cells(.Rows.Count, "A").End(xlUp).Row  
                If .Cells(i, 1).Text <> "" Then  
                    iCountExcel = iCountExcel + 1
                   
                   '1:Nachname,2:Vorname,3:Passwort,4:Pers-Nr.  
                    aToken = .Cells(i, 1).Resize(1, 4).Value
                    
                    sBenutzer = GetAccountName(aToken(1, 2), aToken(1, 1))
                    
                   .Cells(i, 5) = sBenutzer
                    
                    If sBenutzer = "" Then  
                            Call SetLogMsg(aToken(1, 2), aToken(1, 1), "")  
                            Call SetLogErr(LogErr1)
                    ElseIf oUserList.Exists(sBenutzer) = False Then
                        sItem = Array(aToken(1, 1), aToken(1, 2), aToken(1, 3), aToken(1, 4), sBenutzer)
                        oNewUserList.Add "$" & oNewUserList.Count + 1, Join(sItem, ";")  
                    End If
                End If
            Next
        End With
       .Save
       .Close False
    End With

    oExcelApp.Quit:  GetUserDaten = True
End Function

'Mit dieser Funktion werden dem AD neue User hinzugefügt (ungetestet)  
'Der File-Server wird anhand des 1. Buchstabens des Benutzernamens zugeordent.  

Private Sub CreateNewUser(ByRef sNachname, ByRef sVorname, ByRef sPasswort, ByRef sPersNr, sBenutzer)
    Dim oOU, sFileServer, sCmd1, sCmd2, sErrMsg, iResult, i
    
    On Error Resume Next
    
    Select Case LCase(Left(sBenutzer, 1))
        Case "a", "b", "c", "d", "e"  
            sFileServer = "HomeDirSrv01"  
        Case "f", "g", "h", "i", "j"  
            sFileServer = "HomeDirSrv02"  
        Case "k", "l", "m", "n", "o", "p", "q", "r"  
            sFileServer = "HomeDirSrv03"  
        Case Else
            sFileServer = "HomeDirSrv04"  
    End Select
    
    Call SetLogMsg(sVorname, sNachname, sBenutzer)
   
    '#########Entsprechend anpassen  
    Set oOU = GetObject("LDAP://OU=Test,DC=DOMAIN,DC=DE")  
        
    With oOU.Create("user", "CN=" & sBenutzer)  
        .Put "sAMAccountName", sBenutzer  
        .Put "givenName", sVorname  
        .Put "sn", sNachname  
        .Put "displayName", sNachname & " " & sVorname  
        .Put "profilePath", "\\Server1\Profiles$\" & sBenutzer  
        .Put "homeDirectory", "\\" & sFileServer & "\Homedirectory$\" & sBenutzer  
        .Put "homeDrive", "P:"  
        .Put "employeeID", sPersNr  
        .Put "scriptPath", "login.bat"  
        .SetInfo
        .SetPassword sPasswort
        .AccountDisabled = False
        .SetInfo
    End With
        
    If Err Then 
        Call SetLogErr(LogErr2):  Exit Sub
    Else
        oUserList.Add sBenutzer, sNachname & ";" & sVorname  
    End If
    
    iCountADS2 = iCountADS2 + 1
    
    WScript.Sleep (1000)
        
    With CreateObject("Scripting.FilesystemObject")  
        .CreateFolder ("\\" & sFileServer & "\HomeDirectory\" & sBenutzer)  
        .CreateFolder ("\\Server02\Profiles\" & sBenutzer)  
    End With
        
    If Err Then Call SetLogErr(LogErr3):  Exit Sub
    
    sCmd1 = "cacls ""\\" & sFileServer & "\HomeDirectory\" & sBenutzer & """ /t /e /c /g " & _  
            "Domain\Domänen-Admins:F Domain\" & sBenutzer & ":C"  
        
    sCmd2 = "cacls ""\\Server02\Profiles\" & sBenutzer & """ /t /e /c /g " & _  
            "Domain\Domänen-Admins:F Domain\" & sBenutzer & ":C"  

    With CreateObject("WScript.Shell")  
        If .Run(sCmd1, 0, True) Then Err.Raise -1
        If .Run(sCmd2, 0, True) Then Err.Raise -1
    End With
    
    If Err Then Call SetLogErr(LogErr4)
 End Sub


'Diese Funktion gibt den Benutzernamen des User's aus dem ADS zurück oder erstellt einen neuen  
'Benutzernamen unter Berücksichtigung folgender Kriterien:  

'Umlaute werden ersetzt z.B. 'ü' durch 'ue'...  
'Der Benutzername hat eine vorgegebene Länge, die durch die Konstante 'AccountLength' definiert ist.  
'Im Idealfall besteht der Benutzername vom 1. bis zum 2. letzten Buchstaben aus dem Nachnamen und  
'dem ersten Buchstaben des Vornamen. Ansonsten wird der 2. letzte Buchstabe durch eine Ziffern 1-9  
'ersetzt. Bei kürzeren Nachnamen, wird die entsprechenden Anzahl mit dem Vornamen aufgerundet.  
'Beispiele mit den Namen: 'Müller Anton', Müller Andrea', 'Dorn Peter', 'Müller Anton'  
'Ergebnis: 'MuelleA', 'Muell1A', 'DornP', 'Muell2A'  

Private Function GetAccountName(ByRef sVorname, ByRef sNachname)
    Dim oUser, aUser, aUml, sBenutzer, sV, sN, i, x
    
    sBenutzer = ""  
    
    For Each oUser In oUserList
        If LCase(oUserList(oUser)) = LCase(sNachname & ";" & sVorname) Then  
            sBenutzer = oUser:  Exit For
        End If
    Next

    If sBenutzer = "" Then  
        aUml = Array("ä", "ae", "Ä", "Ae", "ö", "oe", "Ö", "Oe", "ü", "ue", "Ü", "Ue")  
    
        sV = sVorname:   sN = sNachname
        
        For i = 0 To UBound(aUml) Step 2
            sV = Replace(sV, aUml(i), aUml(i + 1))
            sN = Replace(sN, aUml(i), aUml(i + 1))
        Next
        
        sV = Left(sV, 1):  sN = Left(sN, AccountLength - 1):  sBenutzer = sN & sV
        
        If oUserList.Exists(sBenutzer) Then
            For i = 1 To 9
                sBenutzer = Left(sN, AccountLength - 2) & i & sV
                If oUserList.Exists(sBenutzer) Then sBenutzer = "" Else Exit For  
            Next
        End If
    End If
End Function

'Diese Funktion fügt dem Log-Text eine Zeile mit dem Usernamen... hinzu  
Private Sub SetLogMsg(ByRef sMsg1, sMsg2, sMsg3)
    sLogMsg = sLogMsg & vbCrLf & "User:  " & sMsg1 & ", " & sMsg2 & ", " & sMsg3 & vbCrLf  
End Sub

'Diese Funktion fügt dem Log-Text eine Zeile mit einer Fehlermeldung hinzu  
Private Sub SetLogErr(ByRef sErr)
    sLogMsg = sLogMsg & Space(13) & sErr & " fehlgeschlagen...  " & vbCrLf  
End Sub

'Diese Funktion schreibt den Log-Text in die Log-Datei (LogFile)  
Private Sub WriteLogFile(ByRef sFile)
    Dim oFso, sHead
    
    sHead = vbCrLf & "Erstellt am:" & Space(12) & Now & vbCrLf & vbCrLf & vbCrLf & "User Gesamt:" _  
                   & Space(8) & "ADS davor:  " & iCountADS1 & Space(8) & "ADS danach:  " _  
                   & iCountADS2 & Space(8) & "Excel-Datei:  " & iCountExcel & vbCrLf & vbCrLf  
    
    Set oFso = CreateObject("Scripting.FileSystemObject")  
    
    With oFso.CreateTextFile(sFile)
        .Write sHead & sLogMsg
        .Close
    End With
End Sub