Automatically create users with VBScript

This VBScript will automatically create and configure users, including Exchange mailbox, home drive (with permissions)...

and user groups. It will need some customisation for your particular site, but it works extremely well and has saved me a lot of time. You could also change it to read the user information from a CSV file.

'Option Explicit
Dim WshShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshNetwork = WScript.CreateObject("WScript.Network")

DomainName = "EnterYourDomainName.com"
OUNamePt1 = "Windows 2000 Users"
OUNamePt2 = "Tunbridge Wells Users"
DefaultPassword = "EnterYourDefaultPassword"
Set dom = GetObject("LDAP://" & DomainName)
InputPrompt1 = "Domain = "&DomainName&vbCrLf&"Container = "&OUName&vbCrLf&vbCrLf&"Enter Users Initials:"
InputPrompt2 = "Domain = "&DomainName&vbCrLf&"Container = "&OUName&vbCrLf&vbCrLf&"Enter Users First Name:"
InputPrompt3 = "Domain = "&DomainName&vbCrLf&"Container = "&OUName&vbCrLf&vbCrLf&"Enter Users Surname:"
InputPrompt4 = "Domain = "&DomainName&vbCrLf&"Container = "&OUName&vbCrLf&vbCrLf&"Enter Users Job Title:"
'InputPrompt5 = "Domain = "&DomainName&vbCrLf&"Container = "&OUName&vbCrLf&vbCrLf&"Please Enter F for Fee Earner or N for Non Fee Earner:"
UserName = InputBox(InputPrompt1, "UserInitials")
FirstName = InputBox(InputPrompt2, "FirstName")
Surname = InputBox(InputPrompt3, "Surname")
Department = InputBox(InputPrompt4, "Job Title")
UserStatus = WshShell.popup("Is this user a Fee Earner",,"User Type",4)
Set usr = dom.Create("user", "CN=" & Surname & ", " & FirstName & ",OU=" & OUNamePt1 & ",OU=" & OUNamePt2)
Set ProfileServer = fso.GetFolder("EnterYourFileServerhome$")

'Create User
usr.put "samAccountName", LCase(UserName)
usr.put "userPrincipalName", FirstName & "." & Surname & "@" & DomainName usr.put "givenName", FirstName
usr.put "sn", Surname
usr.put "displayName", Surname & ", " & FirstName
usr.put "initials", LCase(Mid(UserName,2,1))
usr.put "description", Department
usr.put "homeDirectory", "EnterYourFileServer" & LCase(UserName) & "$"
usr.put "homeDrive", "H:"
usr.put "profilePath", "EnterYourFileServerprofile$" & LCase(UserName)
usr.setinfo usr.setpassword DefaultPassword usr.accountdisabled = False
usr.setinfo

'Create Users Mailbox
Dim oIADSUser
Dim MStore
strDefaultNC = "DC=EnterYourDomainName,DC=com"
Set oIADSUser = GetObject("LDAP://CN=" & Surname & ", " & FirstName & ",OU=Windows 2000 Users,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")

If UCase(Right(Username,1)) <= Chr(76) Then
 MStore = "Mailboxes A-L"
Else
 MStore = "Mailboxes M-Z"
End If

oIADSUser.CreateMailbox "LDAP://CN=" & MStore & ",
CN=First Storage Group,
CN=InformationStore,
CN=EnterYourMailServer,
CN=Servers,
CN=EnterYourAdminGroup,
CN=Administrative Groups,
CN=EnterYourSMTPOrganisationName,
CN=Microsoft Exchange,
CN=Services,
CN=Configuration,
DC=EnterYourDomainName,DC=com"
oIADSUser.SetInfo

'Add member to groups
Const ADS_PROPERTY_APPEND = 3

Set objGroup = GetObject("LDAP://CN=Docs_Users,CN=Users,DC=EnterYourDomainName,DC=com")
objGroup.PutEx ADS_PROPERTY_APPEND, "member",
Array("CN=" & Surname & ", " & FirstName & ",OU=Windows 2000 Users,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")
objGroup.SetInfo

Set objGroup = GetObject("LDAP://CN=SuperScout All Users,CN=Users,DC=EnterYourDomainName,DC=com")
objGroup.PutEx ADS_PROPERTY_APPEND, "member",
Array("CN=" & Surname & ", " & FirstName & ",OU=Windows 2000 Users,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")
objGroup.SetInfo


If UserStatus = vbYes Then
 Set objGroup = GetObject("LDAP://CN=Fee Earners,CN=Users,DC=EnterYourDomainName,DC=com")
 objGroup.PutEx ADS_PROPERTY_APPEND, "member",
Array("CN=" & Surname & ", " & FirstName & ",OU=Windows 2000 Users,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")
 objGroup.SetInfo
 UserStatus = WshShell.popup("Is this user a Trainee Solicitor",,"User Type",4)
 
 If UserStatus = vbYes Then
  Set objGroup = GetObject("LDAP://CN=All Solicitors,OU=Exchange Mailing Lists,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")
  objGroup.PutEx ADS_PROPERTY_APPEND, "member",
Array("CN=" & Surname & ", " & FirstName & ",OU=Windows 2000 Users,OU=Tunbridge Wells Users,DC=EnterYourDomainName,DC=com")
  objGroup.SetInfo
 End If
Else 
 UserStatus = WshShell.popup("Is this user a standard Non Fee Earner",,"User Type",4)

 If UserStatus = vbYes Then
  Set objGroup = GetObject("LDAP://CN=Non Fee Earners,CN=Users,DC=EnterYourDomainName,DC=com")
 Else 
  UserStatus = WshShell.popup("Is this a member of IT",,"User Type",4)
 End If
End If

Wscript.quit

'Create users home directory
If fso.FolderExists(ProfileServer & "" & UserName) = False Then
 fso.CreateFolder(ProfileServer & "" & LCase(UserName))
 fso.CreateFolder(ProfileServer & "" & UserName & "interface") End If

'Share user home directory
AdminServer = "EnterYourAdminServer"
ShareName = LCase(Username) & "$"
FolderName = "E:usershome" & UserName
Set Services = GetObject("WINMGMTS:{impersonationLevel=impersonate,(Security)}!" & AdminServer & "ROOTCIMV2")
Set SecDescClass = Services.Get("Win32_SecurityDescriptor")
Set SecDesc = SecDescClass.SpawnInstance_() 
Set Share = Services.Get("Win32_Share") 
Set InParam = Share.Methods_("Create").InParameters.SpawnInstance_()
InParam.Properties_.Item("Access") = SecDesc
InParam.Properties_.Item("Description") = "Home Directory"
InParam.Properties_.Item("Name") = ShareName
InParam.Properties_.Item("Path") = FolderName
InParam.Properties_.Item("Type") = 0
Share.ExecMethod_"Create", InParam

If fso.FileExists("C:winntsystem32adssecurity.dll") = False Then
 fso.CopyFile("EnterYourFileServerinstallsoftwareadsiadssecurity.dll"),("c:winntsystem32")
 WshShell.Run("%comspec% /c regsvr32.exe /s C:winntsystem32adssecurity.dll")
 Wscript.sleep 50000
End If

ReplaceACL ProfileServer & "" & Username,"add(" & UserName & ":F)+add(domain admins:F)"

Set WshShell = Nothing
Set fso = Nothing
Set WshNetwork = Nothing
Set usr = Nothing
Set NewShare = Nothing
Set Services = Nothing
Set SecDescClass = Nothing
Set SecDesc = Nothing
Set Share = Nothing
Set InParam = Nothing
Set sec = Nothing
Set sd = Nothing
Set dacl = Nothing
Set ace = Nothing
Set oIADSUser = Nothing
Set objGroup = Nothing

MsgBox "The creation of user: " & FirstName & " " & Surname & VbCrLf &_
  "has completed without error"


'Functions

'Set permissions on users home directory Function ReplaceACL(foldernm, permspart)
 foldernm = ProfileServer & "" & Username
 If fso.FolderExists(foldernm)= False Then
  MsgBox "Sorry this folder is not present on the server"
 Else
  ChangeACLS foldernm, permspart, "REPLACE", "FOLDER"
 End If
End Function

'Edit ACLS of specified folder
Function ChangeAcls(FILE,PERMS,REDIT,FFOLDER)

 Const ADS_ACETYPE_ACCESS_ALLOWED = 0
 Const ADS_ACETYPE_ACCESS_DENIED = 1
 Const ADS_ACEFLAG_INHERIT_ACE = 2
 Const ADS_ACEFLAG_SUB_NEW = 9
     
 Set sec = Wscript.CreateObject("ADsSecurity")
 Set sd = sec.GetSecurityDescriptor("FILE://" & FILE)
 Set dacl = sd.DiscretionaryAcl

 If UCase(REDIT)="REPLACE" Then
  For Each existingAce In dacl
  dacl.removeace existingace
  Next
 End If
     
 'break up Perms into individual actions
 cmdArray=split(perms,"+")
   
 For x=0 to ubound(cmdarray)
 tmpVar1=cmdarray(x)
 If UCase(left(tmpVar1,3))="DEL" Then
  ACLAction="DEL"
 Else
  ACLAction="ADD"
 End If

 tmpcmdVar=left(tmpVar1,len(tmpVar1)-1)
 tmpcmdVar=right(tmpcmdVar,len(tmpcmdVar)-4)
 cmdparts=split(tmpcmdVar,":")
 nameVar=cmdparts(0)
 rightVar=cmdparts(1)

 If ACLAction="ADD" Then
  If UCase(FFOLDER)="FOLDER" Then
   addace dacl, namevar, rightvar, ADS_ACETYPE_ACCESS_ALLOWED, ADS_ACEFLAG_SUB_NEW
   addace dacl, namevar, rightvar, ADS_ACETYPE_ACCESS_ALLOWED, ADS_ACEFLAG_INHERIT_ACE
  Else
   addace dacl, namevar, rightvar, ADS_ACETYPE_ACCESS_ALLOWED,0
  End If
 End If
 Next

 For Each ace in dacl
  If instr(ucase(ace.trustee),"NT AUTHORITY") then
   newtrustee=right(ace.trustee, len(ace.trustee)-instr(ace.trustee, ""))
   ace.trustee=newtrustee
  End If
 Next

 sd.DiscretionaryAcl = dacl 
 sec.SetSecurityDescriptor sd

End Function

Function addace(dacl,trustee, maskvar, acetype, aceflags)
 ' add ace to the specified dacl
 Const RIGHT_READ = &H80000000 Const RIGHT_EXECUTE = &H20000000 Const RIGHT_WRITE = &H40000000 Const RIGHT_DELETE = &H10000 Const RIGHT_FULL = &H10000000 Const RIGHT_CHANGE_PERMS = &H40000 Const RIGHT_TAKE_OWNERSHIP = &H80000     
 Set ace = CreateObject("AccessControlEntry")
 ace.Trustee = trustee
 
 Select Case UCase(MaskVar)
 Case "F"
 ace.AccessMask = RIGHT_FULL
 Case "C"
 ace.AccessMask = RIGHT_READ or RIGHT_WRITE or RIGHT_EXECUTE or RIGHT_DELETE
 Case "R"
 ace.AccessMask = RIGHT_READ or RIGHT_EXECUTE
 End Select

 ace.AceType = acetype
 ace.AceFlags = aceflags
 dacl.AddAce ace
End Function

This VBScript tip was submitted to the SearchVB.com tip exchange by member Lee Oliphant. Please let others know how useful it is via the rating scale below. Do you have comments on this tip? Let us know.

Do you have a useful Visual Basic, .NET or Visual Studio tip or code to share? Submit it to our monthly tip contest.