Добавление пользователей в Active Directory

[digorochka]

Нужно помочь исправить скрипт так? что бы он добавлял пользователей не с пустыми паролями, кто может чем-нить подсказать пишите на мыло annsterva@mail.ru

[Duncon]

Где скрипт? или возможна тедлепатическая связь с вашим компом?

[digorochka]

' (c) Bald
' Разумеется, можно свободно все изменять

' Добавляет пользователей с DSN 'adusers' в AD в Ou 'New users'
' ФИО, login, отдел, профиль, логон скрипт, телефон итд
' Создан на основе скрипта, опубликованного Windows 2000 Magazine
' Перед работой скрипта создайте Excel ODBC DSN с именем "adusers"
' указывающий на файл Excel, где сидят имена юзеров
' См. шаблон файла в архиве и примечания к полям там же
' Кроме того, в домене должен существовать OU (подразделение) с адресом
' соответствующим константе sOUAddress

' Замените sOUAddress на имя вашего домена + имя OU
' В данном случае домен называется stat.dom, OU называется "New users"
Const sOUAddress = "LDAP://OU=New users,DC=stat,DC=dom"
Dim ou 'As IADs
Dim usr 'as IADsUser
' Открыть электронную таблицу Excel
' с помощью ADO.
Dim oCN
Set oCN = CreateObject("ADODB.Connection")
oCN.Open "adusers"

' запросом берем из Excel все записи, где есть ФИО и login
' Новые - название рабочего листа в Excel-файле
Dim oRS
Set oRS = oCN.Execute("SELECT * FROM [Новые$] where displayName<>'' and SAMAccountName<>''")

' Поочередно обработать строки набора записей
Do Until oRS.EOF
sDisplayName = trim(oRS("displayName"))
' Заменяем двойные пробелы на одинарные
sDisplayName = RemoveDoubleSpaces(sDisplayName)

' Вычленяем отдельно Фамилию, имя и отчество из sDisplayName
iFirstSpacePos = InStr(sDisplayName," ")
iSecondSpacePos = InStr(iFirstSpacePos+1,sDisplayName," ")
sSurName = mid(sDisplayName,1,iFirstSpacePos-1)
sGivenName = mid(sDisplayName,iFirstSpacePos+1,iSecondSpacePos-iFirstSpacePos-1)
sMiddleName = mid(sDisplayName,iSecondSpacePos+1,Len(sDisplayName)-iSecondSpacePos)

sSAMAccountName = trim(oRS("SAMAccountName"))
sUserPrincipalName = sSAMAccountName & "@stat.dom"
sTitle = oRS("title")
sDescription = oRS("description")
sScriptPath = oRS("scriptPath")
sTelephoneNumber = oRS("telephoneNumber")
sOtherTelephone = oRS("otherTelephone")
sDepartment = oRS("department")
sHomeDirectory = oRS("HomeDirectory")
sHomeDrive = oRS("HomeDrive")
sProfilePath = oRS("ProfilePath")

'WScript.StdOut.Write sDisplayName & VBCRLF

Set ou = GetObject(sOUAddress)
Set usr = ou.Create("user", "CN=" & sDisplayName)
usr.Put "samAccountName", sSAMAccountName
usr.Put "UserPrincipalName", sUserPrincipalName
usr.Put "userPassword", "123456"

usr.Put "displayName", sDisplayName
' Фамилия
usr.Put "sn", sSurName
' Имя
usr.Put "GivenName", sGivenName
' Отчество
usr.Put "MiddleName", sMiddleName
if not isNull(sTitle) then
usr.Put "title", sTitle
end if
if not isNull(sDescription) then
usr.Put "description", sDescription
end if
if not isNull(sScriptPath) then
usr.Put "ScriptPath", sScriptPath
end if
if not isNull(stelephoneNumber) then
usr.Put "telephoneNumber", stelephoneNumber
end if
if not isNull(sdepartment) then
usr.Put "department", sdepartment
end if

if not isNull(sHomeDirectory) then
usr.Put "HomeDirectory", sHomeDirectory
end if
if not isNull(sHomeDrive) then
usr.Put "HomeDrive", sHomeDrive
end if
if not isNull(sProfilePath) then
usr.Put "ProfilePath", sProfilePath
end if

On Error resume next
usr.SetInfo
Select Case Err.Number
case 0
case -2147019886 MsgBox ("Уже существует пользователь с таким именем:" & sDisplayName)
case else MsgBox ("Ошибка при добавлении пользователя. " & Err.Number & Err.Description)
End SELECT
Set ou = Nothing
Set usr = Nothing

' Перейти к следующей строке набора записей.
oRS.MoveNext

Loop

' Заменяем множественные пробелы на одинарные
function RemoveDoubleSpaces(str)
do
str = replace(str, " "," ")
iDoubleSpacePos = InStr(str," ")
loop while iDoubleSpacePos<>0
RemoveDoubleSpaces = str
end function