Automatically create users with VBScript
This VBScript will automatically create and configure users, including exchange mailbox, home drive and user groups.
This VBScript will automatically create and configure users, including Exchange mailbox, home drive (with permissions)...
Continue Reading This Article
Enjoy this article as well as all of our content, including E-Guides, news, tips and more.
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.