Выношу на суд админов подборку из процедур и функций, позволяющих управлять в Windows XP учётными записями ЛОКАЛЬНЫХ пользователей.
| Код |
'#####################################################################
'#
'# Функция GetUserList()
'# Описание: Возвращает список имём всех учётных записей на локальном компьютре
'# Вход : Нет
'# Выход : Символьная строка, содержащая имена пользователей, разделённые ";"
'#####################################################################
Function GetUserList()
Dim S
Dim objWMIService, colItems, objItem
S = ""
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery _
("Select * from Win32_UserAccount Where LocalAccount = True")
For Each objItem in colItems
If S = "" Then S = objItem.Name Else S = S & ";" & objItem.Name
Next
Set colItems = Nothing
Set objWMIService = Nothing
On Error Goto 0
GetUserList = S
End Function
'#####################################################################
'#
'# Функция GetGroupList()
'# Описание: Возвращает список имён всех групп на локальном компьютре
'# Вход : Нет
'# Выход : Символьная строка, содержащая имена групп, разделённые ";"
'#####################################################################
Function GetGroupList()
Dim S
Dim objWMIService, colItems, objItem
S = ""
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery _
("Select * from Win32_Group Where LocalAccount = True")
For Each objItem in colItems
If S = "" Then
S = objItem.Name
Else
S = S & ";" & objItem.Name
End If
Next
On Error Goto 0
GetGroupList = S
End Function
'#####################################################################
'#
'# Функция BuildinAdministratorName()
'# Описание: Определяет имя встроенной учётной записи локального администратора
'# Вход : Нет
'# Выход : Имя встроенного локального администратора (String)
'#####################################################################
Function BuildInAdministratorName()
Dim AdmSID ' SID пользователя
Dim objWMIService, colItems, objItem
On Error Resume Next
BuildInAdministratorName = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery _
("Select * from Win32_UserAccount Where LocalAccount = True")
For Each objItem in colItems
AdmSID = Mid(objItem.SID,1,6) & "*" & _
Mid(objItem.SID, InStrRev(objItem.SID,"-"), _
Len(objItem.SID)-InStrRev(objItem.SID,"-")+1)
If AdmSID = "S-1-5-*-500" Then
BuildInAdministratorName = objItem.Name
Exit For
End If
Next
Set colItems = Nothing
Set objWMIService = Nothing
On Error Goto 0
End Function
'#####################################################################
'#
'# Процедура CreateLocalUser
'# Описание: Создаёт учётную запись пользователя
'# Вход : strUserName - Имя пользователя
'# strPassword - пароль пользователя
'# Выход : Нет
'#####################################################################
Sub CreateLocalUser (byVal strUserName, byVal strPassword)
Dim objComputer
Dim strComputer
Dim colAccounts
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set colAccounts = GetObject("WinNT://" & strComputer & "")
Set objUser = colAccounts.Create("user", strUserName)
objUser.SetPassword strPassword
objUser.SetInfo
Set objUser = Nothing
Set colAccounts = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserPassword
'# Описание: Устанавливает пароль для локальной учётной записи
'# Вход : strUserName - Имя пользователя
'# strPassword - Пароль пользователя
'# Выход : Нет
'#####################################################################
Sub SetUserPassword (byval strUserName, byval strPassword)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.SetPassword strPassword
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserDescription
'# Описание: Устанавливает описание для локальной учётной записи
'# Вход : strUserName - Имя пользователя
'# strDescription - Описание пользователя
'# Выход : Нет
'#####################################################################
Sub SetUserPassword (byval strUserName, byval strDescription)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.Description = strDescription
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserFullName
'# Описание: Устанавливает полное имя для локальной учётной записи
'# Вход : strUserName - Имя пользователя
'# strFullName - Полное имя пользователя
'# Выход : Нет
'#####################################################################
Sub SetUserFullName (byval strUserName, byval strFullName)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.FullName = strFullName
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetCommonProperties
'# Описание: Управляет общими свойствами (галками) учётной записи.
'#
'# Вход : byVal strUserName - имя пользователя
'# ByVal blnRequireChangePassword - требовать/не требовать менять пароль при следующем входе
'# ByVal blnUserCanNotChangePassword - может/не может пользователь менять свой пароль
'# ByVal blnNeverExpirePassword - пароль пользователя никогда не "сгорает" (да/нет)
'# ByVal blnAccountDisabled - пользователь включен/выключен
'# Выход : Нет
'#####################################################################
Sub SetCommonProperties (byVal strUserName, ByVal blnRequireChangePassword, _
ByVal blnUserCanNotChangePassword, _
ByVal blnNeverExpirePassword, _
ByVal blnAccountDisabled )
Dim objComputer
Dim strComputer
Dim colAccounts
Dim objFlag
Dim objUserFlags
Dim objUser
Const ADS_UF_SCRIPT = &H1 ' The logon script will be executed
Const ADS_UF_ACCOUNTDISABLE = &H2 ' Disable user account
Const ADS_UF_HOMEDIR_REQUIRED = &H8 ' Requires a root directory
Const ADS_UF_LOCKOUT = &H10 ' Account is locked out
Const ADS_UF_PASSWD_NOTREQD = &H20 ' No password is required
Const ADS_UF_PASSWD_CANT_CHANGE = &H40 ' The user cannot change the password
Const ADS_UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED = &H80 ' Encrypted password allowed
Const ADS_UF_TEMP_DUPLICATE_ACCOUNT = &H100 ' Local user account
Const ADS_UF_NORMAL_ACCOUNT = &H200 ' Typical user account
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
On Error Resume Next
'# Определяем имя компьютера
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
'# Устанавливаем/Снимает галку с пункта
'# "Потребвать сену пароля при следующем входе в систему"
If Not IsNull(blnRequireChangePassword) Then
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
If blnRequireChangePassword Then
objUser.Put "PasswordExpired", 1
Else
objUser.Put "PasswordExpired", 0
End If
objUser.SetInfo
Set objUser = Nothing
End if
'# Устанавливаем/Снимает галку с пункта
'# "Запретить смену пароля пользователем"
If Not IsNull(blnUserCanNotChangePassword) Then
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUserFlags = objUser.Get("UserFlags")
If blnUserCanNotChangePassword Then
objFlag = objUserFlags Or ADS_UF_PASSWD_CANT_CHANGE
Else
objFlag = objUserFlags And Not ADS_UF_PASSWD_CANT_CHANGE
End If
objUser.Put "userFlags", objFlag
objUser.SetInfo
Set objUser = Nothing
End If
'# Устанавливаем/Снимает галку с пункта
'# "Срок действия пароля не ограничен"
If Not IsNull(blnNeverExpirePassword) Then
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUserFlags = objUser.Get("UserFlags")
If blnNeverExpirePassword Then
objFlag = objUserFlags OR ADS_UF_DONT_EXPIRE_PASSWD
Else
objFlag = objUserFlags And Not ADS_UF_DONT_EXPIRE_PASSWD
End If
objUser.Put "userFlags", objFlag
objUser.SetInfo
Set objUser = Nothing
End if
'# Устанавливаем включена/выключена учётная запись
If Not IsNull(blnAccountDisabled) Then
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUserFlags = objUser.Get("UserFlags")
If blnAccountDisabled Then
objFlag = objUserFlags OR ADS_UF_ACCOUNTDISABLE
Else
objFlag = objUserFlags And Not ADS_UF_ACCOUNTDISABLE
End If
objUser.Put "userFlags", objFlag
objUser.SetInfo
Set objUser = Nothing
End if
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура AddUserToLocalGroup ()
'# Описание: Добавляет пользователя в локальную группу.
'# Вход : byVal strUserName - имя пользователя
'# ByVal strGroupName - Имя группы
'# Выход : Нет
'#####################################################################
Sub AddUserToLocalGroup(byVal strUserName, byVal strGroupName)
Dim objGroup, objUser, objComputer, strComputer
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objGroup = GetObject("WinNT://" & strComputer & "/" & strGroupName & ",group")
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ",user")
objGroup.Add(objUser.ADsPath)
objGroup.SetInfo
Set objUser = Nothing
Set objGroup = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserHomeDirectory
'# Описание: Устанавливает путь к домашней папке
'# Вход : strUserName - Имя пользователя
'# strHomeDirectory - локальный путь к домашней папке
'# Выход : Нет
'#####################################################################
Sub SetUserHomeDirectory (byval strUserName, byval strHomeDirectory)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.HomeDirectory = strHomeDirectory
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserHomeDirDrive
'# Описание: Устанавливает сетевой путь к домашней папке
'# Используется совместно с SetUserHomeDirectory
'# Вход : strUserName - Имя пользователя
'# strHomeDirDrive - имя подключаемого сетевого диска (Например "X:" или "Z:")
'# Выход : Нет
'#####################################################################
Sub SetUserHomeDirDrive (byval strUserName, byval strHomeDirDrive)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.HomeDirDrive = strHomeDirDrive
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура SetUserProfile
'# Описание: Устанавливает путь к профайлу пользователя
'# Вход : strUserName - Имя пользователя
'# strUserProfile - путь к профайлу пользователя
'# Выход : Нет
'#####################################################################
Sub SetUserProfile (byval strUserName, byval strUserProfile)
Dim objComputer
Dim strComputer
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
objUser.Profile = strUserProfile
objUser.SetInfo
Set objUser = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура DeleteLocalUser
'# Описание: Удаляет учётную запись локального пользователя
'# Вход : strUserName - Имя пользователя
'# Выход : Нет
'#####################################################################
Sub DeleteLocalUser (byval strUserName)
Dim objComputer
Dim strComputer
Dim colAccounts
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set colAccounts = GetObject("WinNT://" & strComputer & "")
colAccounts.Delete "user", strUserName
Set colAccounts = Nothing
On Error Goto 0
End Sub
'#####################################################################
'#
'# Процедура RenameLocalUser
'# Описание: Переименовывает учётную запись локального пользователя
'# Вход : strUserName - Имя учётной записи пользователя,
'# strNewUserName - Новое имя учётной записи пользователя
'# Выход : Нет
'#####################################################################
Sub RenameLocalUser (byval strUserName, byVal strNewUserName)
Dim objComputer
Dim strComputer
Dim colAccounts
Dim objUser
On Error Resume Next
Set objComputer = CreateObject("Shell.LocalMachine")
strComputer = objComputer.MachineName
Set objComputer = Nothing
Set objUser = GetObject("WinNT://" & strComputer & "/" & strUserName & ", user")
Set objComputer = GetObject("WinNT://" & strComputer)
objComputer.MoveHere objUser.AdsPath, strNewUserName
Set objComputer = Nothing
Set objUser = Nothing
On Error Goto 0
End Sub
|
Пример использования
| Код |
Call CreateLocalUser ("АрсеньевА", "1q2w!Q@W" )
Call AddUserToLocalGroup ("АрсеньевА", "Опытные пользователи" )
Call SetCommonPropertyes ("АрсеньевА", False, True, True, False)
Call SetUserProfile ("АрсеньевА", "D:\D&S\%UserName%")
|
|
, немного подправил скрипт. Теперь все должно работать 
