bsharath
asked on
Create users and mailboxes from a excel
Hi,
I want to create all users and mailboxes that i have in a excel sheet.
This Q is a continuation of this.
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Regards
SHarath
I want to create all users and mailboxes that i have in a excel sheet.
This Q is a continuation of this.
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Regards
SHarath
ASKER
Yes Chandru
ASKER
Chandru in the above link i think Rob was mentioning about you.Did the Hta file work?
ASKER
Chandru did you get the Hta script working which you and Rob worked on...
If yes can you share the working code.I can raise a Q for it...
Rob was telling me that he does not know if the code worked for you and he does not have an exchange to test...
If yes can you share the working code.I can raise a Q for it...
Rob was telling me that he does not know if the code worked for you and he does not have an exchange to test...
Hey Chandru, how are you?
Looks like we may have a chance to put our ideas together here.....Chandru, I will await your response...As Sharath has mentioned, I am not sure whether the HTA code (or just the Exchange mailbox creation) was working properly.
Regards,
Rob.
Looks like we may have a chance to put our ideas together here.....Chandru, I will await your response...As Sharath has mentioned, I am not sure whether the HTA code (or just the Exchange mailbox creation) was working properly.
Regards,
Rob.
Hi Rob,
Nice meeting you once again. I didn't get a chance to test the HTA. I was about to work with you to make further improvements on the script.
I will test this today and will post the results in the morning tomorrow?
sharath - Sorry for the delay in reply. Was very busy from morning...
regards
Chandru
Nice meeting you once again. I didn't get a chance to test the HTA. I was about to work with you to make further improvements on the script.
I will test this today and will post the results in the morning tomorrow?
sharath - Sorry for the delay in reply. Was very busy from morning...
regards
Chandru
ASKER
Ok chandru.I hope you and Rob can get a extremely Good stuff togeather
ASKER
chandru_sol
Any chance of you checking ?
Any chance of you checking ?
Sharath,
I will post the code as i didn't get a chance to test the code.
Sorry guys!
I will post the code as i didn't get a chance to test the code.
Sorry guys!
ASKER
Ok Chandru awaiting for it
Hi Sharath,
Sorry for the delay.....
Here is the code for that HTA which myself and Rob were working a month before.
Rob - We will be requiring your assistance asusual to get this script completed
Code starts here
<html>
<head>
<title>Eroom User Account Creation Form v1.0</title>
<HTA:APPLICATION
ID = "AccountCreationApp"
VERSION="1.0"
APPLICATIONNAME="AD Account Creation"
SYSMENU="yes"
MAXIMIZEBUTTON="yes"
MINIMIZEBUTTON="yes"
BORDER="thin"
INNERBORDER="no"
SCROLL="auto"
SINGLEINSTANCE="yes"
WINDOWSTATE="maximize"
>
</hta>
<style>
BODY
{
background-color: #008B8B;
font-family: Helvetica;
font-size: 8pt;
margin-top: 10px;
margin-left: 20px;
margin-right: 10px;
margin-bottom: 10px;
}
TD
{
font-family: Trebuchet MS;
font-size: 8pt;
}
LEGEND
{
font-family: Trebuchet MS;
font-size: 10pt;
}
SELECT
{
font-family: Trebuchet MS;
font-size: 8pt;
width:195px
}
INPUT
{
font-family: Trebuchet MS;
font-size: 8pt;
}
</style>
<script language="VBScript">
Dim defaultNC, BaseOU
defaultNC = GetObject("LDAP://RootDSE" ).Get("Def aultNaming Context")
BaseOU = "OU=Domain Clients," & defaultNC
Logpath ="C:\logs\"
Const FORAPPENDING = 8
Sub Window_OnLoad
Dim width, height, x, y
width = 800
height = 620
x = (window.screen.width - width) / 2
y = (window.screen.height - height) / 2
If x < 0 Then x = 0
If y < 0 Then y = 0
window.resizeTo width,height
window.moveTo x,y
'Check if this HTA is running under the correct account
Set wshNetwork = CreateObject("WScript.Netw ork")
strComputer = wshNetwork.ComputerName
strCurrentDomain = wshNetwork.UserDomain
strCurrentUser = wshNetwork.UserName
span_Logo.InnerHTML = "<img src='Active-Directory-Mana gement.jpg ' height=100 width=200><br><br>"
span_User.InnerHTML = "<br><br><br><br><br><font size='1' color='White'>Currently running program as:<b>" & strCurrentDomain & "\" & strCurrentUser & "</b></font><br><br>"
strRequiredDomain = "Domainname"
strRequiredUser = "Domainadminusername"
strHTAPath = Replace(Mid(Document.URL, 8), "%20", " ")
If Left(strHTAPath, 2) <> "\\" And Left(strHTAPath, 2) <> "C:" Then
MsgBox "Please run this program from a local drive or a UNC path"
Window.Close
Exit Sub
End If
Set objFSO = CreateObject("Scripting.Fi leSystemOb ject")
If LCase(strRequiredDomain & "\" & strRequiredUser) <> LCase(strCurrentDomain & "\" & strCurrentUser) Then
strRequiredPassword = InputBox("This program is not running under the user account of " & strRequiredDomain & "\" & strRequiredUser & "." & VbCrLf &_
"Please enter the password for the required account, and the program will be restarted:", "Incorrect User")
strPSExecPath = "\\server\Scripts\psexec.e xe"
strCommand = "cmd /c " & objFSO.GetFile(strPSExecPa th).ShortP ath & " -accepteula \\" & strComputer & " -i -d -u " & strRequiredDomain & "\" & strRequiredUser & " -p " & strRequiredPassword & " mshta.exe " & objFSO.GetFile(strHTAPath) .ShortPath
'InputBox "Prompt", "Title", strCommand
Set objShell = CreateObject("WScript.Shel l")
objShell.Run strCommand, 0, False
Window.Close
End If
Call Populate_Office
Call Populate_Domain_Controller s
Call Populate_Exchange_Servers
End Sub
Sub Populate_Office()
strHTML = "<select size='1' name='cbxSite'>" & VbCrLf
Set objFSO = CreateObject("Scripting.Fi leSystemOb ject")
strRootPath = Replace(Mid(Document.URL, 8), "%20", " ")
strRootPath = Left(strRootPath, InStrRev(strRootPath, "\"))
strOfficeFile = strRootPath & "OfficeLocations.txt"
If objFSO.FileExists(strOffic eFile) = False Then
MsgBox strOfficeFile & " not found. Cannot create Office Locations."
Exit Sub
End If
Set objOfficeFile = objFSO.OpenTextFile(strOff iceFile, 1, False)
While Not objOfficeFile.AtEndOfStrea m
strOffice = objOfficeFile.ReadLine
If strOffice <> "" Then
strHTML = strHTML & "<option value='" & strOffice & "'>" & strOffice & "</option>" & vbCrLf
End If
Wend
objOfficeFile.Close
strHTML = strHTML & "<option selected value='cbxOfficeAlert'>-- Select Users Office --</option>" & vbCrLf
strHTML = strHTML & "</select>"
span_Office.InnerHTML = strHTML
Set objOfficeFile = Nothing
Set objFSO = Nothing
End Sub
Sub Populate_Domain_Controller s()
strHTML = "<select size='1' name='cbxDCServer'>" & VbCrLf
strHTML = strHTML & "<option selected value='cbxDCServerAlert'>- - Select DC Server --</option>" & vbCrLf
Dim objRootDSE, strConfig, adoConnection, adoCommand, strQuery
Dim adoRecordset, objDC, objSite
Const adVarChar = 200
Set SortRs = CreateObject("ADOR.Records et")
SortRs.fields.append "canonicalName",adVarChar, 255
SortRs.open
' Determine configuration context from RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE" )
strConfig = objRootDSE.Get("configurat ionNamingC ontext")
' Use ADO to search Active Directory for ObjectClass nTDSDSA.
Set adoCommand = CreateObject("ADODB.Comman d")
Set adoConnection = CreateObject("ADODB.Connec tion")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnectio n = adoConnection
strQuery = "<LDAP://" & strConfig _
& ">;(ObjectClass=nTDSDSA);A dsPath;sub tree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Pag e Size") = 100
adoCommand.Properties("Tim eout") = 30
adoCommand.Properties("Cac he Results") = False
Set adoRecordset = adoCommand.Execute
' The parent object of each object with ObjectClass=nTDSDSA is a Domain
' Controller. The parent of each Domain Controller is a "Servers"
' container, and the parent of this container is the "Site" container.
Do Until adoRecordset.EOF
Set objDC = GetObject( _
GetObject(adoRecordset.Fie lds("AdsPa th").Value ).Parent)
Set objSite = GetObject(GetObject(objDC. Parent).Pa rent)
'strHTML = strHTML & "<option value='" & objDC.cn & "'>" & objDC.cn & "</option>" & VbCrLf
SortRs.AddNew
SortRs.Fields("canonicalNa me") = objDC.cn
SortRs.Update
'Wscript.Echo "Domain Controller: " & objDC.cn & vbCrLf _
' & "DNS Host Name: " & objDC.DNSHostName & vbCrLf _
' & "Site: " & objSite.name
adoRecordset.MoveNext
Loop
adoRecordset.Close
With SortRs
.Sort = "canonicalName asc"
.MoveFirst
While Not .EOF
strHTML = strHTML & "<option value='" & .Fields("canonicalName") & "'>" & .Fields("canonicalName") & "</option>" & VbCrLf
.MoveNext
Wend
End With
strHTML = strHTML & "</select>"
span_DCServer.InnerHTML = strHTML
' Clean up.
adoConnection.Close
Set objRootDSE = Nothing
Set adoCommand = Nothing
Set adoConnection = Nothing
Set adoRecordset = Nothing
Set objDC = Nothing
Set objSite = Nothing
Set SortRs = Nothing
End Sub
Sub Populate_Exchange_Servers( )
' POPULATE THE EXCHANGE SERVER LIST BOX
strHTML = "<select size='1' name='cbxExchServer' onChange='Populate_Storage Groups()'> " & vbCrLf
Set cn = createobject("ADODB.Connec tion")
Set cmd = createobject("ADODB.Comman d")
Set rs = createobject("ADODB.Record set")
Set objRoot = getobject("LDAP://RootDSE" )
configurationNC = objRoot.Get("configuration namingcont ext")
cn.open "Provider=ADsDSOObject;"
cmd.activeconnection = cn
cmd.commandtext = "<LDAP://" & configurationNC & _
">;(objectCategory=msExchE xchangeSer ver);name; subtree"
Set rs = cmd.execute
While rs.eof <> True And rs.bof <> True
strHTML = strHTML & "<option value='" & rs(0) & "'>" & rs(0) & "</option>" & VbCrLf
rs.movenext
Wend
cn.close
strHTML = strHTML & "<option selected value='cbxExchServerAlert' >-- Select Exchange Server --</option>" & vbCrLf
strHTML = strHTML & "</select>"
span_ExchServer.InnerHTML = strHTML
End Sub
Sub Populate_StorageGroups()
'THIS PROCEDURE POPULATE THE cbxStorageGroup and cbxExch List Boxes
' for the Storage Group and the Mailstore
strHTML = "<select size='1' name='cbxStorageGrp' onChange='Populate_MailSto res()'>" & VbCrLf
Dim objRootDSE,objConfiguratio n
Dim cat,conn
Dim cmd,RS
Set objRootDSE = GetObject("LDAP://rootDSE" )
x=1
strSrv=cbxExchServer.Value
strConfiguration = "LDAP://" & objRootDSE.Get("configurat ionNamingC ontext")
Set objConfiguration = GetObject(strConfiguration )
strQuery="Select name,cn,distinguishedname from '" & _
objConfiguration.ADSPath & "' Where objectclass='msExchStorage Group'"
set cat=GetObject("GC:")
for each obj in cat
set GC=obj
Next
AdsPath=GC.ADSPath
set conn=Createobject("ADODB.C onnection" )
set cmd=CreateObject("ADODB.Co mmand")
conn.Provider="ADSDSOObjec t"
conn.Open
set cmd.ActiveConnection=conn
set RS=conn.Execute(strQuery)
'WScript.Echo "Mailbox stores on " & UCase(strSrv) & ":"
Do while not RS.EOF
DN=rs.Fields("distinguishe dname")
'CN=RS.Fields("cn")
NM=RS.Fields("name")
If InStr(UCase(DN),UCase(strS rv)) Then
'WScript.Echo x & ") " &DN
'WScript.Echo "Name: " & NM
'WScript.Echo "CN: " & cn
strHTML = strHTML & "<option value='" & NM & "'>" & NM & "</option>" & VbCrLf
x=x+1
End If
rs.movenext
Loop
rs.Close
conn.Close
strHTML = strHTML & "<option selected value='cbxStorageGrpAlert' >-- Select Storage Group --</option>" & vbCrLf
strHTML = strHTML & "</select>"
span_StorageGroup.InnerHTM L = strHTML
End Sub
Sub Populate_MailStores()
strHTML = "<select size='1' name='cbxExch'>" & VbCrLf
'Dim objRootDSE,objConfiguratio n
'Dim cat,conn
'Dim cmd,RS
Set objRootDSE = GetObject("LDAP://rootDSE" )
x=1
strSrv = cbxExchServer.Value
strConfiguration = "LDAP://" & objRootDSE.Get("configurat ionNamingC ontext")
Set objConfiguration = GetObject(strConfiguration )
strQuery="Select name,cn,distinguishedname from '" & _
objConfiguration.ADSPath & "' Where objectclass='msExchPrivate MDB'"
set cat=GetObject("GC:")
for each obj In cat
set GC=obj
Next
AdsPath=GC.ADSPath
set conn=Createobject("ADODB.C onnection" )
set cmd=CreateObject("ADODB.Co mmand")
conn.Provider="ADSDSOObjec t"
conn.Open
set cmd.ActiveConnection=conn
set RS=conn.Execute(strQuery)
'WScript.Echo "Storage groups on " & UCase(strSrv) & ":"
Do while not RS.EOF
DN=rs.Fields("distinguishe dname")
CN=RS.Fields("cn")
NM=RS.Fields("name")
If InStr(UCase(DN),UCase(strS rv)) And InStr(UCase(DN),UCase(cbxS torageGrp. Value)) Then
strHTML = strHTML & "<option value='" & NM & "'>" & NM & "</option>" & VbCrLf
' WScript.Echo x & ") " &DN
' WScript.Echo "Name: " & NM
' WScript.Echo "CN: " & CN
x=x+1
End If
rs.movenext
Loop
rs.Close
conn.Close
Set objRootDSE=Nothing
Set objConfiguration=Nothing
Set cat=Nothing
Set conn=Nothing
Set cmd=Nothing
Set RS=Nothing
strHTML = strHTML & "<option selected value='cbxExchAlert'>-- Select Server/Mailstore --</option>" & VbCrLf
strHTML = strHTML & "</select>"
span_cbxExch.InnerHTML = strHTML
End Sub
Sub chkExch_OnClick()
If chkExch.checked = True Then
cbxExch.Disabled = 0
Else
cbxExch.Disabled = 1
End If
End Sub
Sub chkDL_OnClick()
If chkDL.checked = True Then
cbxDL.Disabled = 1
Else
cbxDL.Disabled = 0
End If
End Sub
' ## Start user account creation process ##
Sub CreateAccount
strUser = txtUser.Value
If strUser = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strFirst = txtFirst.Value
If strFirst = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strInitial = txtMiddle.Value
strLast = txtLast.Value
If strLast = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strDisplay = UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
strTitle = txtTitle.Value
strOffice = cbxSite.Value
strDepartment = txtDepartment.Value
strCompany = txtCompany.Value
strManager = txtManager.Value
strCN = UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
Set objConnection = CreateObject("ADODB.Connec tion")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Comman d")
objCommand.ActiveConnectio n = objConnection
objCommand.CommandText = _
"<GC://" & defaultNC & ">;(&(objectCategory=Perso n)(objectC lass=user) " & _
"(samAccountName=" & strUser & "));samAccountName;subtree "
Set objRecordSet = objCommand.Execute
If objRecordSet.RecordCount = 0 Then
Else
MsgBox "The User Account already exists.",48,"Alert"
Exit Sub
End If
objConnection.Close
Const FORWRITING= 2
Const ADS_UF_ACCOUNTDISABLE = 2
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
' ## Determine if Creation of User Mailbox required ##
If chkExch.checked = "True" And cbxExch.value = "cbxExchAlert" Then
MsgBox "You must select either a Server/Mailstore or " & vbcrlf _
& "de-select the 'Create Mailbox' checkbox." ,64, "Alert"
Exit Sub
End If
' ## Add user to required Distribution List ##
If chkDL.checked ="True" And cbxDL.value = "cbxDLAlert" Then
MsgBox "You must select a Distribution List or " & vbcrlf _
& "de-select the 'Distribution List' checkbox." ,64, "Alert"
Exit Sub
End If
' ## Ensure users site/office selected ##
If cbxSite.Value = "cbxOfficeAlert" Then
MsgBox "You must select the users office.",64, "Alert"
Exit Sub
End If
Select Case cbxSite.Value
Case "Birmingham"
strOffice = "Birmingham"
strLDAPdn = "OU=_ Birmingham," & BaseOU
strUserServer = "Northsea"
Case "Exeter"
strOffice = "Exeter"
strLDAPdn = "OU=_ Exeter," & BaseOU
strUserServer = "Cluster"
Case "Hatfield"
strOffice = "Hatfield"
strLDAPdn = "OU=_ Hatfield," & BaseOU
strUserServer = "Data1Hat"
Case "Leeds"
strOffice = "Leeds"
strLDAPdn = "OU=_ Leeds," & BaseOU
strUserServer = "Sagat"
Case "Newcastle"
strOffice = "Newcastle"
strLDAPdn = "OU=_ Newcastle," & BaseOU
strUserServer = "fluorine" <!-- Arsenic -->
Case "Other"
strOffice = "Other"
strLDAPdn = "OU=_ Other," & BaseOU
strUserServer = "fluorine"
Case "Other"
strOffice = "Other"
strLDAPdn = "OU=_ Oxford," & BaseOU
strUserServer = "Data1Oxf"
Case "Paddington"
strOffice = "Paddington"
strLDAPdn = "OU=_ Paddington," & BaseOU
strUserServer = "Data1Pad"
Case "Portland House"
strOffice = "Portland"
strLDAPdn = "OU=_ Portland House," & BaseOU
strUserServer = "Data1Pot"
Case "Redditch"
strOffice = "Redditch"
strLDAPdn = "OU=_ Redditch," & BaseOU
strUserServer = "Red-DC"
Case "Richmond House"
strOffice = "Richmond House"
strLDAPdn = "OU=_ Richmond House," & BaseOU
strUserServer = "Data1Rich"
Case "Slough"
strOffice = "Slough"
strLDAPdn = "OU=_ Slough," & BaseOU
strUserServer = "Data1Slo"
Case "Tavistock"
strOffice = "Tavistock House"
strLDAPdn = "OU=_ Tavistock House," & BaseOU
strUserServer = "fluorine" <!-- maverick -->
Case "Winchester"
strOffice = "Winchester"
strLDAPdn = "OU=_ Winchester," & BaseOU
strUserServer = "fluorine"
End Select
Set objOU = GetObject("LDAP://" & strLDAPdn)
Set objUser = objOU.Create("User", "cn=" & strCN)
objUser.Put "sAMAccountName", LCase(strUser)
objUser.SetInfo
objUser.Put "givenName", UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
If strInitial <> "" Then
objUser.Put "initials", UCase(Left(strInitial, 1)) & LCase(Right(strInitial, Len(strInitial) - 1))
End If
objUser.Put "sn", UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1))
objUser.Put "displayName", UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
If strTitle <> "" Then
objUser.put "title", strTitle
End If
If strDepartment <> "" Then
objUser.put "department", strDepartment
End If
If strCompany <> "" Then
objUser.put "company", strCompany
End If
If strManager <> "" Then
objUser.put "manager", strManager
End If
objUser.put "physicalDeliveryOfficeNam e", strOffice
objUser.put "description", strTitle
objUser.Put "userPrincipalName", LCase(strUser) & "@" & defaultNC
objUser.SetPassword "welcome"
objUser.Put "pwdLastSet", 0
intUAC = objUser.Get("userAccountCo ntrol")
If intUAC And ADS_UF_ACCOUNTDISABLE Then
objUser.Put"userAccountCon trol", intUAC Xor ADS_UF_ACCOUNTDISABLE
End If
objUser.SetInfo
' ## Add Users to selected groups ##
If chkGrpOne.Checked Then
Set objGroup = GetObject _
("LDAP://cn=NPFIT,OU=Other Mail-enabled Security Groups,OU=Groups,OU=__ Migration Staging," & BaseOU)
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
If chkGrpTwo.Checked Then
Set objGroup = GetObject _
("LDAP://cn=Share - NPSO Files,OU=File Share Access,OU=Groups,OU=__ Migration Staging," & BaseOU)
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
If chkGrpThree.Checked Then
Set objGroup = GetObject _
("LDAP://cn=Shared Data,OU=Universal Security,OU=Groups (Don't Migrate?),OU=_ Migration Staging - DO NOT MOVE OR ADD OBJECTS HERE!," & defaultNC)
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
' ## Create User Mailbox Process ##
If ChkExch.Checked Then
Call CreateMailbox (strCN,strLDAPdn)
End If
' ## Create User Folder Process ##
If chkUserFolder.Checked Then
Call CreateUserFolder (strUser,strUserServer)
End If
' ## Writes entry into logfile ##
If chkLogging.Checked Then
WriteLog("Account Created: " & DateToStr() & ", " & Time() & ", " & strUser _
& ", " & strFirst & " " & strLast & ", " & strOffice)
End If
' ## Reloads Page on completion of User Creation ##
Location.Reload(True)
MsgBox "User Successfully Created.",64, "Alert - User Creation Successful."
End Sub
Sub CreateMailbox (strCN,strLDAPdn)
' ## Start Mail Account Creation Process ##
Dim oIADSUser
Dim strMStore
Set oIADSUser = GetObject("LDAP://cn=" & strCN & "," & strLDAPdn)
' ## EXCHPE MAIL STORES ##
Select Case cbxExch.Value
Case "EXCHPEA2G"
strExchServer = "EXCHPE"
strMStore = "A2G"
strStoreGP = "2nd Storage Group"
Case "EXCHPEH2M"
strExchServer = "EXCHPE"
strMStore = "H2M"
strStoreGP = "2nd Storage Group"
Case "EXCHPEN2S"
strExchServer = "EXCHPE"
strMStore = "N2S"
strStoreGP = "3rd Storage Group"
Case "EXCHPET2Z"
strExchServer = "EXCHPE"
strMStore = "T2Z"
strStoreGP = "3rd Storage Group"
' ## EXCHAQ2 MAIL STORES ##
Case "EXCHAQ2A2G"
strExchServer = "EXCHAQ2"
strMStore = "A2G"
strStoreGP = "2nd Storage Group"
Case "EXCHAQ2H2M"
strExchServer = "EXCHAQ2"
strMStore = "H2M"
strStoreGP = "2nd Storage Group"
Case "EXCHAQ2N2S"
strExchServer = "EXCHAQ2"
strMStore = "N2S"
strStoreGP = "3rd Storage Group"
Case "EXCHAQ2T2Z"
strExchServer = "EXCHAQ2"
strMStore = "T2Z"
strStoreGP = "3rd Storage Group"
Case "ODIN"
strExchServer = "ODIN"
strMStore = "Mailbox Store (ODIN)"
strStoreGP = "First Storage Group"
End Select
oIADSUser.CreateMailbox ("LDAP://CN=" & strMStore & ",CN=" & strStoreGP & ",CN=InformationStore,CN=" & strExchServer & ",CN=Servers,CN=NHSIA,CN=A dministrat ive Groups,CN=NHS,CN=Microsoft Exchange,CN=Services,CN=Co nfiguratio n,DC=nhsia ,DC=nhs,DC =uk")
oIADSUser.SetInfo
' ## End of Mail Account Creation Process ##
End Sub
Sub CreateUserFolder (strUser,strUserServer)
' ## If Users Home Server is flourine then Users home drive has to be created manually ##
If strUserServer = "fluorine" Then
MsgBox "User folder must be created manually.",16, "Alert - Folder Creation Unsuccessful."
Exit Sub
End If
' ## Create the Users home folder on respective server ##
Set objFSO = CreateObject("Scripting.Fi leSystemOb ject")
Set objFolder = objFSO.GetFolder("\\" & strUserServer & "\users")
' ## Create users home folder ##
If objFSO.FolderExists("\\" & strUserServer & "\users\" & strUser) = False Then
objFSO.CreateFolder("\\" & strUserServer & "\users\" & LCase(strUser))
End If
' ## Assign user change NTFS permissions on home drives ##
Set objShell = CreateObject("Wscript.Shel l")
strUserFolder = "\\" & strUserServer & "\users\" & strUser
objShell.Run ("SetACL.exe -on """ & strUserFolder & """ -ot file -actn ace " & "-ace ""n:npfit.nhs.uk\" & strUser & ";p:change""")
End Sub
Sub WriteLog (strMessage)
Dim LogFile
Dim fs
Dim fsOut
Logfile = Logpath & "AccountCreation.log"
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fsOut = fs.OpenTextFile(LogFile, ForAppending, True)
fsOut.WriteLine (strMessage)
fsOut.Close
End Sub
Function DateToStr()
DateToStr = DatePart("d",Now) & "/" & DatePart("m",Now) & "/" & DatePart("yyyy",Now)
End Function
' ## Reloads Page on pressing [Clear Form] ##
Sub Reload
Location.Reload(True)
End Sub
' ## Closes page on pressing [Exit] ##
Sub CloseForm
Window.Close
End Sub 'CloseForm
Sub About()
On Error Resume Next
strAbout="Eroom User Account Creation Form v1.0" & VbCrLf
strAbout= strAbout & "_________________________ ___" & vbTab & VbCrLf & VbCrLf
strAbout=strAbout & " Company name" & VbCrLf & VbCrLf
strAbout=strAbout & " Author: Chandru" & VbCrLf
strAbout=strAbout & " Date: 13 May 2007" & vbcrlf & vbcrlf
strAbout= strAbout & "_________________________ ___" & VbCrLf & VbCrLf
MsgBox strAbout,vbOKOnly+vbInform ation,"Abo ut"
End Sub
Sub CreateAccount2()
If txtFirst.Value = "" Then
MsgBox "Please enter a first name.",64, "Alert"
Exit Sub
End If
If txtLast.Value = "" Then
MsgBox "Please enter a last name.",64, "Alert"
Exit Sub
End If
If cbxDCServer.Value = "cbxDCServerAlert" Then
MsgBox "You must select a DC Server.",64, "Alert"
Exit Sub
End If
If cbxExchServer.Value = "cbxExchServerAlert" Then
MsgBox "You must select an Exchange Server.",64, "Alert"
Exit Sub
End If
If cbxStorageGrp.Value = "cbxStorageGrpAlert" Then
MsgBox "You must select a StorageGroup.",64, "Alert"
Exit Sub
End If
If cbxExch.Value = "cbxExchAlert" Then
MsgBox "You must select an Exchange Server.",64, "Alert"
Exit Sub
End If
If cbxMbxLanguage.Value = "cbxMbxLanguageAlert" Then
MsgBox "You must select a Mailbox Language.",64, "Alert"
Exit Sub
End If
strDCServerName = cbxDCServer.Value
strServerName = cbxExchServer.Value
strStorageGroup = cbxStorageGrp.Value
strMailboxStore = cbxExch.Value
strGivenName = txtFirst.Value
strSurname = txtLast.Value
strFolderLang = cbxMbxLanguage.Value
'Call AutomateMailboxCreation(st rDCServerN ame, strServerName, strStorageGroup, strMailboxStore, strGivenName, strSurname, strFolderLang)
MsgBox "AutomateMailboxCreation(" & strDCServerName & ", " & strServerName & ", " & strStorageGroup & ", " & strMailboxStore & ", " & strGivenName & ", " & strSurname & ", " & strFolderLang & ")"
End Sub
</script>
</head>
<body>
<!-- Start Of Main Table -->
<table width="710" border="0" cellspacing="0" CellSpacing="0">
<tr><td width="350" Valign="top" align="center">
<!-- LHS Of Main Table -->
<table border="0" cellspacing="0" CellSpacing="0">
<span id="span_Logo"></span>
<tr><td width="350">
<!-- Username/Logon name -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Use rname/Logo n name</b></legend>
<table border="0" cellpadding="3" width="350">
<tr><td width="110">Logon name:</td><td><input type="text"
name="txtUser" style="width:195px"></td>< td> < /td></tr>
<tr><td>First Name: </td><td><input type="text" name="txtFirst" style="width:195px"></td>< td
width="50"> </td></tr >
<tr><td>Last Name: </td><td><input type="text" name="txtLast" style="width:195px"></td>< td> < /td></tr>
</table><p></fieldset></ta ble>
<!-- End of Username/Logon name -->
<!-- User Account Properties -->
<table border="0" cellpadding="0" cellspacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Use r Account Properties</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="110">Job Title:</td><td><input type="text" name="txtTitle" style="width:195px"></td>< td> < /td>
</tr>
<tr><td>Office: </td>
<td align="right">
<SPAN id="span_Office"></SPAN>
</td>
<td> </td>
</tr>
<tr>
<td>Department: </td><td><input type="text" name="txtDepartment" style="width:195px"></td>< td width="50"> </td>
</tr>
<tr>
<td>Company: </td><td><input type="text" name="txtCompany" value="Company name" style="width:195px"></td>< td> < /td>
</tr>
<tr>
<td>Manager: </td><td><input type="text" name="txtManager" style="width:195px"></td>
</tr>
<td>Manager: </td><td><input type="text" name="txtManager" style="width:195px"></td>
</tr>
</table><p></fieldset></ta ble>
<!-- End of User Account Properties -->
<!-- Group Membership -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr>
<td valign="top" colspan="3"><fieldset><leg end><b>Gro up Membership</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="150"><b>Group Name</b></td><td width="200" align="middle">Select to add user to group(s)</td>
</tr>
<tr>
<td width="150">NPFIT (File Access)</td><td width="200" align="middle"><input type="checkbox" name="chkGrpOne"></td>
</tr>
<tr>
<td width="150">Share - NPSO Files</td><td width="200" align="middle"><input type="checkbox" name="chkGrpTwo"></td>
</tr>
<tr>
<td width="150">Shared Data <font size="3" color="red"><b>*</b></font ></td><td width="200" align="middle"><input type="checkbox" name="chkGrpThree" disabled="False"></td>
</tr>
</table><p></fieldset></ta ble>
<!-- End of Group Membership -->
<!-- End of LHS Of Main Table -->
</td></tr></table>
</td>
<td width="350" Valign="top">
<!-- RHS Of Main Table -->
<span id="span_User"></span>
<table border="0" cellspacing="0" CellSpacing="0">
<tr><td width="350">
<!-- Create User Mail Account -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Use r Mail Account</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Create user mailbox?</td><td width="50" align="middle"><input type="checkbox" name="chkExch"checked="Fal se"disable d="False"> </td>
</tr></table>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="125">
DC Server:
</td>
<td align="right">
<SPAN ID='span_DCServer'></SPAN>
</td>
</tr>
<tr>
<td width="125">
Exchange Server:
</td>
<td align="right">
<SPAN ID='span_ExchServer'></SPA N>
</td>
</tr>
<tr>
<td width="125">
Storage Group:
</td>
<td align="right">
<SPAN ID='span_StorageGroup'></S PAN>
</td>
</tr>
<tr>
<td width="125">
Server/Mailstore:
</td>
<td align="right">
<SPAN ID='span_cbxExch'></SPAN>
</td>
</tr>
<tr>
<td width="125">
Mailbox Language:
</td>
<td align="right">
<select size="1" name="cbxMbxLanguage">
<option value="en-us">Engish (US)</option>
<option value="kor">Korean</option >
<option selected value="cbxMbxLanguageAlert ">-- Select Mailbox Language --</option>
</select>
</td>
</tr>
</table><p></fieldset></ta ble>
<!-- End of Create User Mailbox -->
<!-- Add to Distribution Lists -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Dis tribution Lists</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Add user to Distribution List?</td><td width="50" align="middle"><input type="checkbox" name="chkDL" disabled="false"></td>
</tr></table>
<table border="0" cellpadding="3" width="350">
<tr><td width="125">Distribution List: <font size="3" color="red"><b>*</b></font ></td>
<td align="right"><select size="1" name="cbxDL" disabled="true">
<option value="DLBirmingham">Aqueo us II</option>
<option value="DLExeter">DL Exeter</option>
<option value="DLOxford">DL Oxford</option>
<option value="DLPortland ">DL Portland</option>
<option value="DLHatfield">DL Hatfield</option>
<option value="DLHuntingdon">DL Huntingdon</option>
<option value="DLNewcastle">DL Newcastle</option>
<option value="DLPaddington">DL Paddington</option>
<option value="DLSlough">DL Slough</option>
<option value="DLTavistock">DL Tavistock House</option>
<option selected value="cbxDLAlert">-- Select Distribution List --</option>
</select></td>
</tr>
</table><p></fieldset></ta ble>
<!-- End of Add to Distribution Lists -->
<!-- Create User Home Directory -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Use r Home Directory</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Create User Home Directory?</td><td width="50" align="middle">
<input type="checkbox" name="chkUserFolder" checked="false">
</td></tr>
</table><p></fieldset></ta ble>
<!-- End Of Create User Home Directory -->
<!-- Enable Logging -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg end><b>Ena ble Logging</b></legend>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Enable Logging?</td><td width="50" align="middle">
<input type="checkbox" name="chkLogging" checked="false">
</td></tr>
</table><p></fieldset></ta ble>
<!-- End Of Enable Logging -->
<table border="0" cellspacing="0" cellpadding="0" width="350">
<tr>
<td valign="top">
<!-- Blank Table for future additions/features -->
<b>NOTE:</b> Items marked with <font size="3" color="red"><b>*</b></font > are disabled until the next version is complete.
</td></tr>
<b>NOTE:</b> <font size="1" color="White"><b><blink>Th e new user account object will have an default password - Pa$$word12</blink></b></fo nt>
</td></tr>
</table>
<!-- End of RHS Of Main Table -->
</td></tr></table>
</td></tr></table>
<!-- End Of Main Table -->
<table align="center" border="0" cellspacing="0" cellpadding="0" width="350">
<tr>
<td align="right" valign="bottom">
<input type="button" value=" About " onclick="About">
<input type="button" value="Clear Form" onclick="Reload" title=" Click to Clear Form ">
<input type="button" value=" Submit " onClick="CreateAccount2" title=" Click to Create User Account ">
<input type="button" value=" Exit " onclick="CloseForm" title=" Click to Exit Form ">
</td></tr>
</table>
</body>
</html>
regards
Chandru
Sorry for the delay.....
Here is the code for that HTA which myself and Rob were working a month before.
Rob - We will be requiring your assistance asusual to get this script completed
Code starts here
<html>
<head>
<title>Eroom User Account Creation Form v1.0</title>
<HTA:APPLICATION
ID = "AccountCreationApp"
VERSION="1.0"
APPLICATIONNAME="AD Account Creation"
SYSMENU="yes"
MAXIMIZEBUTTON="yes"
MINIMIZEBUTTON="yes"
BORDER="thin"
INNERBORDER="no"
SCROLL="auto"
SINGLEINSTANCE="yes"
WINDOWSTATE="maximize"
>
</hta>
<style>
BODY
{
background-color: #008B8B;
font-family: Helvetica;
font-size: 8pt;
margin-top: 10px;
margin-left: 20px;
margin-right: 10px;
margin-bottom: 10px;
}
TD
{
font-family: Trebuchet MS;
font-size: 8pt;
}
LEGEND
{
font-family: Trebuchet MS;
font-size: 10pt;
}
SELECT
{
font-family: Trebuchet MS;
font-size: 8pt;
width:195px
}
INPUT
{
font-family: Trebuchet MS;
font-size: 8pt;
}
</style>
<script language="VBScript">
Dim defaultNC, BaseOU
defaultNC = GetObject("LDAP://RootDSE"
BaseOU = "OU=Domain Clients," & defaultNC
Logpath ="C:\logs\"
Const FORAPPENDING = 8
Sub Window_OnLoad
Dim width, height, x, y
width = 800
height = 620
x = (window.screen.width - width) / 2
y = (window.screen.height - height) / 2
If x < 0 Then x = 0
If y < 0 Then y = 0
window.resizeTo width,height
window.moveTo x,y
'Check if this HTA is running under the correct account
Set wshNetwork = CreateObject("WScript.Netw
strComputer = wshNetwork.ComputerName
strCurrentDomain = wshNetwork.UserDomain
strCurrentUser = wshNetwork.UserName
span_Logo.InnerHTML = "<img src='Active-Directory-Mana
span_User.InnerHTML = "<br><br><br><br><br><font
strRequiredDomain = "Domainname"
strRequiredUser = "Domainadminusername"
strHTAPath = Replace(Mid(Document.URL, 8), "%20", " ")
If Left(strHTAPath, 2) <> "\\" And Left(strHTAPath, 2) <> "C:" Then
MsgBox "Please run this program from a local drive or a UNC path"
Window.Close
Exit Sub
End If
Set objFSO = CreateObject("Scripting.Fi
If LCase(strRequiredDomain & "\" & strRequiredUser) <> LCase(strCurrentDomain & "\" & strCurrentUser) Then
strRequiredPassword = InputBox("This program is not running under the user account of " & strRequiredDomain & "\" & strRequiredUser & "." & VbCrLf &_
"Please enter the password for the required account, and the program will be restarted:", "Incorrect User")
strPSExecPath = "\\server\Scripts\psexec.e
strCommand = "cmd /c " & objFSO.GetFile(strPSExecPa
'InputBox "Prompt", "Title", strCommand
Set objShell = CreateObject("WScript.Shel
objShell.Run strCommand, 0, False
Window.Close
End If
Call Populate_Office
Call Populate_Domain_Controller
Call Populate_Exchange_Servers
End Sub
Sub Populate_Office()
strHTML = "<select size='1' name='cbxSite'>" & VbCrLf
Set objFSO = CreateObject("Scripting.Fi
strRootPath = Replace(Mid(Document.URL, 8), "%20", " ")
strRootPath = Left(strRootPath, InStrRev(strRootPath, "\"))
strOfficeFile = strRootPath & "OfficeLocations.txt"
If objFSO.FileExists(strOffic
MsgBox strOfficeFile & " not found. Cannot create Office Locations."
Exit Sub
End If
Set objOfficeFile = objFSO.OpenTextFile(strOff
While Not objOfficeFile.AtEndOfStrea
strOffice = objOfficeFile.ReadLine
If strOffice <> "" Then
strHTML = strHTML & "<option value='" & strOffice & "'>" & strOffice & "</option>" & vbCrLf
End If
Wend
objOfficeFile.Close
strHTML = strHTML & "<option selected value='cbxOfficeAlert'>-- Select Users Office --</option>" & vbCrLf
strHTML = strHTML & "</select>"
span_Office.InnerHTML = strHTML
Set objOfficeFile = Nothing
Set objFSO = Nothing
End Sub
Sub Populate_Domain_Controller
strHTML = "<select size='1' name='cbxDCServer'>" & VbCrLf
strHTML = strHTML & "<option selected value='cbxDCServerAlert'>-
Dim objRootDSE, strConfig, adoConnection, adoCommand, strQuery
Dim adoRecordset, objDC, objSite
Const adVarChar = 200
Set SortRs = CreateObject("ADOR.Records
SortRs.fields.append "canonicalName",adVarChar,
SortRs.open
' Determine configuration context from RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE"
strConfig = objRootDSE.Get("configurat
' Use ADO to search Active Directory for ObjectClass nTDSDSA.
Set adoCommand = CreateObject("ADODB.Comman
Set adoConnection = CreateObject("ADODB.Connec
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnectio
strQuery = "<LDAP://" & strConfig _
& ">;(ObjectClass=nTDSDSA);A
adoCommand.CommandText = strQuery
adoCommand.Properties("Pag
adoCommand.Properties("Tim
adoCommand.Properties("Cac
Set adoRecordset = adoCommand.Execute
' The parent object of each object with ObjectClass=nTDSDSA is a Domain
' Controller. The parent of each Domain Controller is a "Servers"
' container, and the parent of this container is the "Site" container.
Do Until adoRecordset.EOF
Set objDC = GetObject( _
GetObject(adoRecordset.Fie
Set objSite = GetObject(GetObject(objDC.
'strHTML = strHTML & "<option value='" & objDC.cn & "'>" & objDC.cn & "</option>" & VbCrLf
SortRs.AddNew
SortRs.Fields("canonicalNa
SortRs.Update
'Wscript.Echo "Domain Controller: " & objDC.cn & vbCrLf _
' & "DNS Host Name: " & objDC.DNSHostName & vbCrLf _
' & "Site: " & objSite.name
adoRecordset.MoveNext
Loop
adoRecordset.Close
With SortRs
.Sort = "canonicalName asc"
.MoveFirst
While Not .EOF
strHTML = strHTML & "<option value='" & .Fields("canonicalName") & "'>" & .Fields("canonicalName") & "</option>" & VbCrLf
.MoveNext
Wend
End With
strHTML = strHTML & "</select>"
span_DCServer.InnerHTML = strHTML
' Clean up.
adoConnection.Close
Set objRootDSE = Nothing
Set adoCommand = Nothing
Set adoConnection = Nothing
Set adoRecordset = Nothing
Set objDC = Nothing
Set objSite = Nothing
Set SortRs = Nothing
End Sub
Sub Populate_Exchange_Servers(
' POPULATE THE EXCHANGE SERVER LIST BOX
strHTML = "<select size='1' name='cbxExchServer' onChange='Populate_Storage
Set cn = createobject("ADODB.Connec
Set cmd = createobject("ADODB.Comman
Set rs = createobject("ADODB.Record
Set objRoot = getobject("LDAP://RootDSE"
configurationNC = objRoot.Get("configuration
cn.open "Provider=ADsDSOObject;"
cmd.activeconnection = cn
cmd.commandtext = "<LDAP://" & configurationNC & _
">;(objectCategory=msExchE
Set rs = cmd.execute
While rs.eof <> True And rs.bof <> True
strHTML = strHTML & "<option value='" & rs(0) & "'>" & rs(0) & "</option>" & VbCrLf
rs.movenext
Wend
cn.close
strHTML = strHTML & "<option selected value='cbxExchServerAlert'
strHTML = strHTML & "</select>"
span_ExchServer.InnerHTML = strHTML
End Sub
Sub Populate_StorageGroups()
'THIS PROCEDURE POPULATE THE cbxStorageGroup and cbxExch List Boxes
' for the Storage Group and the Mailstore
strHTML = "<select size='1' name='cbxStorageGrp' onChange='Populate_MailSto
Dim objRootDSE,objConfiguratio
Dim cat,conn
Dim cmd,RS
Set objRootDSE = GetObject("LDAP://rootDSE"
x=1
strSrv=cbxExchServer.Value
strConfiguration = "LDAP://" & objRootDSE.Get("configurat
Set objConfiguration = GetObject(strConfiguration
strQuery="Select name,cn,distinguishedname from '" & _
objConfiguration.ADSPath & "' Where objectclass='msExchStorage
set cat=GetObject("GC:")
for each obj in cat
set GC=obj
Next
AdsPath=GC.ADSPath
set conn=Createobject("ADODB.C
set cmd=CreateObject("ADODB.Co
conn.Provider="ADSDSOObjec
conn.Open
set cmd.ActiveConnection=conn
set RS=conn.Execute(strQuery)
'WScript.Echo "Mailbox stores on " & UCase(strSrv) & ":"
Do while not RS.EOF
DN=rs.Fields("distinguishe
'CN=RS.Fields("cn")
NM=RS.Fields("name")
If InStr(UCase(DN),UCase(strS
'WScript.Echo x & ") " &DN
'WScript.Echo "Name: " & NM
'WScript.Echo "CN: " & cn
strHTML = strHTML & "<option value='" & NM & "'>" & NM & "</option>" & VbCrLf
x=x+1
End If
rs.movenext
Loop
rs.Close
conn.Close
strHTML = strHTML & "<option selected value='cbxStorageGrpAlert'
strHTML = strHTML & "</select>"
span_StorageGroup.InnerHTM
End Sub
Sub Populate_MailStores()
strHTML = "<select size='1' name='cbxExch'>" & VbCrLf
'Dim objRootDSE,objConfiguratio
'Dim cat,conn
'Dim cmd,RS
Set objRootDSE = GetObject("LDAP://rootDSE"
x=1
strSrv = cbxExchServer.Value
strConfiguration = "LDAP://" & objRootDSE.Get("configurat
Set objConfiguration = GetObject(strConfiguration
strQuery="Select name,cn,distinguishedname from '" & _
objConfiguration.ADSPath & "' Where objectclass='msExchPrivate
set cat=GetObject("GC:")
for each obj In cat
set GC=obj
Next
AdsPath=GC.ADSPath
set conn=Createobject("ADODB.C
set cmd=CreateObject("ADODB.Co
conn.Provider="ADSDSOObjec
conn.Open
set cmd.ActiveConnection=conn
set RS=conn.Execute(strQuery)
'WScript.Echo "Storage groups on " & UCase(strSrv) & ":"
Do while not RS.EOF
DN=rs.Fields("distinguishe
CN=RS.Fields("cn")
NM=RS.Fields("name")
If InStr(UCase(DN),UCase(strS
strHTML = strHTML & "<option value='" & NM & "'>" & NM & "</option>" & VbCrLf
' WScript.Echo x & ") " &DN
' WScript.Echo "Name: " & NM
' WScript.Echo "CN: " & CN
x=x+1
End If
rs.movenext
Loop
rs.Close
conn.Close
Set objRootDSE=Nothing
Set objConfiguration=Nothing
Set cat=Nothing
Set conn=Nothing
Set cmd=Nothing
Set RS=Nothing
strHTML = strHTML & "<option selected value='cbxExchAlert'>-- Select Server/Mailstore --</option>" & VbCrLf
strHTML = strHTML & "</select>"
span_cbxExch.InnerHTML = strHTML
End Sub
Sub chkExch_OnClick()
If chkExch.checked = True Then
cbxExch.Disabled = 0
Else
cbxExch.Disabled = 1
End If
End Sub
Sub chkDL_OnClick()
If chkDL.checked = True Then
cbxDL.Disabled = 1
Else
cbxDL.Disabled = 0
End If
End Sub
' ## Start user account creation process ##
Sub CreateAccount
strUser = txtUser.Value
If strUser = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strFirst = txtFirst.Value
If strFirst = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strInitial = txtMiddle.Value
strLast = txtLast.Value
If strLast = "" Then
MsgBox "You are missing required fields.",64, "Alert"
Exit Sub
End If
strDisplay = UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
strTitle = txtTitle.Value
strOffice = cbxSite.Value
strDepartment = txtDepartment.Value
strCompany = txtCompany.Value
strManager = txtManager.Value
strCN = UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
Set objConnection = CreateObject("ADODB.Connec
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Comman
objCommand.ActiveConnectio
objCommand.CommandText = _
"<GC://" & defaultNC & ">;(&(objectCategory=Perso
"(samAccountName=" & strUser & "));samAccountName;subtree
Set objRecordSet = objCommand.Execute
If objRecordSet.RecordCount = 0 Then
Else
MsgBox "The User Account already exists.",48,"Alert"
Exit Sub
End If
objConnection.Close
Const FORWRITING= 2
Const ADS_UF_ACCOUNTDISABLE = 2
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
' ## Determine if Creation of User Mailbox required ##
If chkExch.checked = "True" And cbxExch.value = "cbxExchAlert" Then
MsgBox "You must select either a Server/Mailstore or " & vbcrlf _
& "de-select the 'Create Mailbox' checkbox." ,64, "Alert"
Exit Sub
End If
' ## Add user to required Distribution List ##
If chkDL.checked ="True" And cbxDL.value = "cbxDLAlert" Then
MsgBox "You must select a Distribution List or " & vbcrlf _
& "de-select the 'Distribution List' checkbox." ,64, "Alert"
Exit Sub
End If
' ## Ensure users site/office selected ##
If cbxSite.Value = "cbxOfficeAlert" Then
MsgBox "You must select the users office.",64, "Alert"
Exit Sub
End If
Select Case cbxSite.Value
Case "Birmingham"
strOffice = "Birmingham"
strLDAPdn = "OU=_ Birmingham," & BaseOU
strUserServer = "Northsea"
Case "Exeter"
strOffice = "Exeter"
strLDAPdn = "OU=_ Exeter," & BaseOU
strUserServer = "Cluster"
Case "Hatfield"
strOffice = "Hatfield"
strLDAPdn = "OU=_ Hatfield," & BaseOU
strUserServer = "Data1Hat"
Case "Leeds"
strOffice = "Leeds"
strLDAPdn = "OU=_ Leeds," & BaseOU
strUserServer = "Sagat"
Case "Newcastle"
strOffice = "Newcastle"
strLDAPdn = "OU=_ Newcastle," & BaseOU
strUserServer = "fluorine" <!-- Arsenic -->
Case "Other"
strOffice = "Other"
strLDAPdn = "OU=_ Other," & BaseOU
strUserServer = "fluorine"
Case "Other"
strOffice = "Other"
strLDAPdn = "OU=_ Oxford," & BaseOU
strUserServer = "Data1Oxf"
Case "Paddington"
strOffice = "Paddington"
strLDAPdn = "OU=_ Paddington," & BaseOU
strUserServer = "Data1Pad"
Case "Portland House"
strOffice = "Portland"
strLDAPdn = "OU=_ Portland House," & BaseOU
strUserServer = "Data1Pot"
Case "Redditch"
strOffice = "Redditch"
strLDAPdn = "OU=_ Redditch," & BaseOU
strUserServer = "Red-DC"
Case "Richmond House"
strOffice = "Richmond House"
strLDAPdn = "OU=_ Richmond House," & BaseOU
strUserServer = "Data1Rich"
Case "Slough"
strOffice = "Slough"
strLDAPdn = "OU=_ Slough," & BaseOU
strUserServer = "Data1Slo"
Case "Tavistock"
strOffice = "Tavistock House"
strLDAPdn = "OU=_ Tavistock House," & BaseOU
strUserServer = "fluorine" <!-- maverick -->
Case "Winchester"
strOffice = "Winchester"
strLDAPdn = "OU=_ Winchester," & BaseOU
strUserServer = "fluorine"
End Select
Set objOU = GetObject("LDAP://" & strLDAPdn)
Set objUser = objOU.Create("User", "cn=" & strCN)
objUser.Put "sAMAccountName", LCase(strUser)
objUser.SetInfo
objUser.Put "givenName", UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
If strInitial <> "" Then
objUser.Put "initials", UCase(Left(strInitial, 1)) & LCase(Right(strInitial, Len(strInitial) - 1))
End If
objUser.Put "sn", UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1))
objUser.Put "displayName", UCase(Left(strLast, 1)) & LCase(Right(strLast, Len(strLast) - 1)) & " " _
& UCase(Left(strFirst, 1)) & LCase(Right(strFirst, Len(strFirst) - 1))
If strTitle <> "" Then
objUser.put "title", strTitle
End If
If strDepartment <> "" Then
objUser.put "department", strDepartment
End If
If strCompany <> "" Then
objUser.put "company", strCompany
End If
If strManager <> "" Then
objUser.put "manager", strManager
End If
objUser.put "physicalDeliveryOfficeNam
objUser.put "description", strTitle
objUser.Put "userPrincipalName", LCase(strUser) & "@" & defaultNC
objUser.SetPassword "welcome"
objUser.Put "pwdLastSet", 0
intUAC = objUser.Get("userAccountCo
If intUAC And ADS_UF_ACCOUNTDISABLE Then
objUser.Put"userAccountCon
End If
objUser.SetInfo
' ## Add Users to selected groups ##
If chkGrpOne.Checked Then
Set objGroup = GetObject _
("LDAP://cn=NPFIT,OU=Other
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
If chkGrpTwo.Checked Then
Set objGroup = GetObject _
("LDAP://cn=Share - NPSO Files,OU=File Share Access,OU=Groups,OU=__ Migration Staging," & BaseOU)
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
If chkGrpThree.Checked Then
Set objGroup = GetObject _
("LDAP://cn=Shared Data,OU=Universal Security,OU=Groups (Don't Migrate?),OU=_ Migration Staging - DO NOT MOVE OR ADD OBJECTS HERE!," & defaultNC)
objGroup.PutEx ADS_PROPERTY_APPEND, _
"member", Array("cn=" & strCN & "," & strLDAPdn)
objGroup.SetInfo
End If
' ## Create User Mailbox Process ##
If ChkExch.Checked Then
Call CreateMailbox (strCN,strLDAPdn)
End If
' ## Create User Folder Process ##
If chkUserFolder.Checked Then
Call CreateUserFolder (strUser,strUserServer)
End If
' ## Writes entry into logfile ##
If chkLogging.Checked Then
WriteLog("Account Created: " & DateToStr() & ", " & Time() & ", " & strUser _
& ", " & strFirst & " " & strLast & ", " & strOffice)
End If
' ## Reloads Page on completion of User Creation ##
Location.Reload(True)
MsgBox "User Successfully Created.",64, "Alert - User Creation Successful."
End Sub
Sub CreateMailbox (strCN,strLDAPdn)
' ## Start Mail Account Creation Process ##
Dim oIADSUser
Dim strMStore
Set oIADSUser = GetObject("LDAP://cn=" & strCN & "," & strLDAPdn)
' ## EXCHPE MAIL STORES ##
Select Case cbxExch.Value
Case "EXCHPEA2G"
strExchServer = "EXCHPE"
strMStore = "A2G"
strStoreGP = "2nd Storage Group"
Case "EXCHPEH2M"
strExchServer = "EXCHPE"
strMStore = "H2M"
strStoreGP = "2nd Storage Group"
Case "EXCHPEN2S"
strExchServer = "EXCHPE"
strMStore = "N2S"
strStoreGP = "3rd Storage Group"
Case "EXCHPET2Z"
strExchServer = "EXCHPE"
strMStore = "T2Z"
strStoreGP = "3rd Storage Group"
' ## EXCHAQ2 MAIL STORES ##
Case "EXCHAQ2A2G"
strExchServer = "EXCHAQ2"
strMStore = "A2G"
strStoreGP = "2nd Storage Group"
Case "EXCHAQ2H2M"
strExchServer = "EXCHAQ2"
strMStore = "H2M"
strStoreGP = "2nd Storage Group"
Case "EXCHAQ2N2S"
strExchServer = "EXCHAQ2"
strMStore = "N2S"
strStoreGP = "3rd Storage Group"
Case "EXCHAQ2T2Z"
strExchServer = "EXCHAQ2"
strMStore = "T2Z"
strStoreGP = "3rd Storage Group"
Case "ODIN"
strExchServer = "ODIN"
strMStore = "Mailbox Store (ODIN)"
strStoreGP = "First Storage Group"
End Select
oIADSUser.CreateMailbox ("LDAP://CN=" & strMStore & ",CN=" & strStoreGP & ",CN=InformationStore,CN="
oIADSUser.SetInfo
' ## End of Mail Account Creation Process ##
End Sub
Sub CreateUserFolder (strUser,strUserServer)
' ## If Users Home Server is flourine then Users home drive has to be created manually ##
If strUserServer = "fluorine" Then
MsgBox "User folder must be created manually.",16, "Alert - Folder Creation Unsuccessful."
Exit Sub
End If
' ## Create the Users home folder on respective server ##
Set objFSO = CreateObject("Scripting.Fi
Set objFolder = objFSO.GetFolder("\\" & strUserServer & "\users")
' ## Create users home folder ##
If objFSO.FolderExists("\\" & strUserServer & "\users\" & strUser) = False Then
objFSO.CreateFolder("\\" & strUserServer & "\users\" & LCase(strUser))
End If
' ## Assign user change NTFS permissions on home drives ##
Set objShell = CreateObject("Wscript.Shel
strUserFolder = "\\" & strUserServer & "\users\" & strUser
objShell.Run ("SetACL.exe -on """ & strUserFolder & """ -ot file -actn ace " & "-ace ""n:npfit.nhs.uk\" & strUser & ";p:change""")
End Sub
Sub WriteLog (strMessage)
Dim LogFile
Dim fs
Dim fsOut
Logfile = Logpath & "AccountCreation.log"
Set fs = CreateObject("Scripting.Fi
Set fsOut = fs.OpenTextFile(LogFile, ForAppending, True)
fsOut.WriteLine (strMessage)
fsOut.Close
End Sub
Function DateToStr()
DateToStr = DatePart("d",Now) & "/" & DatePart("m",Now) & "/" & DatePart("yyyy",Now)
End Function
' ## Reloads Page on pressing [Clear Form] ##
Sub Reload
Location.Reload(True)
End Sub
' ## Closes page on pressing [Exit] ##
Sub CloseForm
Window.Close
End Sub 'CloseForm
Sub About()
On Error Resume Next
strAbout="Eroom User Account Creation Form v1.0" & VbCrLf
strAbout= strAbout & "_________________________
strAbout=strAbout & " Company name" & VbCrLf & VbCrLf
strAbout=strAbout & " Author: Chandru" & VbCrLf
strAbout=strAbout & " Date: 13 May 2007" & vbcrlf & vbcrlf
strAbout= strAbout & "_________________________
MsgBox strAbout,vbOKOnly+vbInform
End Sub
Sub CreateAccount2()
If txtFirst.Value = "" Then
MsgBox "Please enter a first name.",64, "Alert"
Exit Sub
End If
If txtLast.Value = "" Then
MsgBox "Please enter a last name.",64, "Alert"
Exit Sub
End If
If cbxDCServer.Value = "cbxDCServerAlert" Then
MsgBox "You must select a DC Server.",64, "Alert"
Exit Sub
End If
If cbxExchServer.Value = "cbxExchServerAlert" Then
MsgBox "You must select an Exchange Server.",64, "Alert"
Exit Sub
End If
If cbxStorageGrp.Value = "cbxStorageGrpAlert" Then
MsgBox "You must select a StorageGroup.",64, "Alert"
Exit Sub
End If
If cbxExch.Value = "cbxExchAlert" Then
MsgBox "You must select an Exchange Server.",64, "Alert"
Exit Sub
End If
If cbxMbxLanguage.Value = "cbxMbxLanguageAlert" Then
MsgBox "You must select a Mailbox Language.",64, "Alert"
Exit Sub
End If
strDCServerName = cbxDCServer.Value
strServerName = cbxExchServer.Value
strStorageGroup = cbxStorageGrp.Value
strMailboxStore = cbxExch.Value
strGivenName = txtFirst.Value
strSurname = txtLast.Value
strFolderLang = cbxMbxLanguage.Value
'Call AutomateMailboxCreation(st
MsgBox "AutomateMailboxCreation("
End Sub
</script>
</head>
<body>
<!-- Start Of Main Table -->
<table width="710" border="0" cellspacing="0" CellSpacing="0">
<tr><td width="350" Valign="top" align="center">
<!-- LHS Of Main Table -->
<table border="0" cellspacing="0" CellSpacing="0">
<span id="span_Logo"></span>
<tr><td width="350">
<!-- Username/Logon name -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr><td width="110">Logon name:</td><td><input type="text"
name="txtUser" style="width:195px"></td><
<tr><td>First Name: </td><td><input type="text" name="txtFirst" style="width:195px"></td><
width="50"> </td></tr
<tr><td>Last Name: </td><td><input type="text" name="txtLast" style="width:195px"></td><
</table><p></fieldset></ta
<!-- End of Username/Logon name -->
<!-- User Account Properties -->
<table border="0" cellpadding="0" cellspacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="110">Job Title:</td><td><input type="text" name="txtTitle" style="width:195px"></td><
</tr>
<tr><td>Office: </td>
<td align="right">
<SPAN id="span_Office"></SPAN>
</td>
<td> </td>
</tr>
<tr>
<td>Department: </td><td><input type="text" name="txtDepartment" style="width:195px"></td><
</tr>
<tr>
<td>Company: </td><td><input type="text" name="txtCompany" value="Company name" style="width:195px"></td><
</tr>
<tr>
<td>Manager: </td><td><input type="text" name="txtManager" style="width:195px"></td>
</tr>
<td>Manager: </td><td><input type="text" name="txtManager" style="width:195px"></td>
</tr>
</table><p></fieldset></ta
<!-- End of User Account Properties -->
<!-- Group Membership -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr>
<td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="150"><b>Group Name</b></td><td width="200" align="middle">Select to add user to group(s)</td>
</tr>
<tr>
<td width="150">NPFIT (File Access)</td><td width="200" align="middle"><input type="checkbox" name="chkGrpOne"></td>
</tr>
<tr>
<td width="150">Share - NPSO Files</td><td width="200" align="middle"><input type="checkbox" name="chkGrpTwo"></td>
</tr>
<tr>
<td width="150">Shared Data <font size="3" color="red"><b>*</b></font
</tr>
</table><p></fieldset></ta
<!-- End of Group Membership -->
<!-- End of LHS Of Main Table -->
</td></tr></table>
</td>
<td width="350" Valign="top">
<!-- RHS Of Main Table -->
<span id="span_User"></span>
<table border="0" cellspacing="0" CellSpacing="0">
<tr><td width="350">
<!-- Create User Mail Account -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Create user mailbox?</td><td width="50" align="middle"><input type="checkbox" name="chkExch"checked="Fal
</tr></table>
<table border="0" cellpadding="3" width="350">
<tr>
<td width="125">
DC Server:
</td>
<td align="right">
<SPAN ID='span_DCServer'></SPAN>
</td>
</tr>
<tr>
<td width="125">
Exchange Server:
</td>
<td align="right">
<SPAN ID='span_ExchServer'></SPA
</td>
</tr>
<tr>
<td width="125">
Storage Group:
</td>
<td align="right">
<SPAN ID='span_StorageGroup'></S
</td>
</tr>
<tr>
<td width="125">
Server/Mailstore:
</td>
<td align="right">
<SPAN ID='span_cbxExch'></SPAN>
</td>
</tr>
<tr>
<td width="125">
Mailbox Language:
</td>
<td align="right">
<select size="1" name="cbxMbxLanguage">
<option value="en-us">Engish (US)</option>
<option value="kor">Korean</option
<option selected value="cbxMbxLanguageAlert
</select>
</td>
</tr>
</table><p></fieldset></ta
<!-- End of Create User Mailbox -->
<!-- Add to Distribution Lists -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Add user to Distribution List?</td><td width="50" align="middle"><input type="checkbox" name="chkDL" disabled="false"></td>
</tr></table>
<table border="0" cellpadding="3" width="350">
<tr><td width="125">Distribution List: <font size="3" color="red"><b>*</b></font
<td align="right"><select size="1" name="cbxDL" disabled="true">
<option value="DLBirmingham">Aqueo
<option value="DLExeter">DL Exeter</option>
<option value="DLOxford">DL Oxford</option>
<option value="DLPortland ">DL Portland</option>
<option value="DLHatfield">DL Hatfield</option>
<option value="DLHuntingdon">DL Huntingdon</option>
<option value="DLNewcastle">DL Newcastle</option>
<option value="DLPaddington">DL Paddington</option>
<option value="DLSlough">DL Slough</option>
<option value="DLTavistock">DL Tavistock House</option>
<option selected value="cbxDLAlert">-- Select Distribution List --</option>
</select></td>
</tr>
</table><p></fieldset></ta
<!-- End of Add to Distribution Lists -->
<!-- Create User Home Directory -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Create User Home Directory?</td><td width="50" align="middle">
<input type="checkbox" name="chkUserFolder" checked="false">
</td></tr>
</table><p></fieldset></ta
<!-- End Of Create User Home Directory -->
<!-- Enable Logging -->
<table border="0" cellspacing="0" CellSpacing="0" width="350">
<tr><td valign="top" colspan="3"><fieldset><leg
<table border="0" cellpadding="3" width="350">
<tr>
<td width="300">Enable Logging?</td><td width="50" align="middle">
<input type="checkbox" name="chkLogging" checked="false">
</td></tr>
</table><p></fieldset></ta
<!-- End Of Enable Logging -->
<table border="0" cellspacing="0" cellpadding="0" width="350">
<tr>
<td valign="top">
<!-- Blank Table for future additions/features -->
<b>NOTE:</b> Items marked with <font size="3" color="red"><b>*</b></font
</td></tr>
<b>NOTE:</b> <font size="1" color="White"><b><blink>Th
</td></tr>
</table>
<!-- End of RHS Of Main Table -->
</td></tr></table>
</td></tr></table>
<!-- End Of Main Table -->
<table align="center" border="0" cellspacing="0" cellpadding="0" width="350">
<tr>
<td align="right" valign="bottom">
<input type="button" value=" About " onclick="About">
<input type="button" value="Clear Form" onclick="Reload" title=" Click to Clear Form ">
<input type="button" value=" Submit " onClick="CreateAccount2" title=" Click to Create User Account ">
<input type="button" value=" Exit " onclick="CloseForm" title=" Click to Exit Form ">
</td></tr>
</table>
</body>
</html>
regards
Chandru
ASKER
Thanks Chandru,
Rob
For the HTA to suit my network what are the changes i need to do.?
I get this.
-------------------------- -
Error
-------------------------- -
A Runtime Error has occurred.
Do you wish to Debug?
Line: 680
Error: Object required: 'cbxDCServer'
-------------------------- -
Yes No
-------------------------- -
Rob
For the HTA to suit my network what are the changes i need to do.?
I get this.
--------------------------
Error
--------------------------
A Runtime Error has occurred.
Do you wish to Debug?
Line: 680
Error: Object required: 'cbxDCServer'
--------------------------
Yes No
--------------------------
ASKER
Rob & Chandru,
For the Hta code you gave me i have changed the OU path and the Domain admin name so now i am able to see all my Dc's and exchanges.
I get this now.
-------------------------- -
-------------------------- -
AutomateMailboxCreation(IN DC01, INEXCHANGE1, First Storage Group, Mailbox Store (INEXCHANGE1), Sharma, Kumar, en-us)
-------------------------- -
OK
-------------------------- -
For the Hta code you gave me i have changed the OU path and the Domain admin name so now i am able to see all my Dc's and exchanges.
I get this now.
--------------------------
--------------------------
AutomateMailboxCreation(IN
--------------------------
OK
--------------------------
ASKER
Rob did you have time to look into it....
Hi Sharath,
Can you give this script a try? Hope this suits your needs
http://www.msexchange.org/articles/Creating-Exchange-Users-Excel.html
regards
Chandru
Can you give this script a try? Hope this suits your needs
http://www.msexchange.org/articles/Creating-Exchange-Users-Excel.html
regards
Chandru
Did you manage to try this script?
ASKER
Chandru i would require help in tuning it up to my Domain..
Have you tried it...If yes can you help me...
Have you tried it...If yes can you help me...
ASKER
I use this script as per the website...
Sub CreateUsers()
Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser
Set rootDSE = GetObject(LDAP://RootDSE)
DomainContainer = rootDSE.Get("defaultNaming Context")
Set oOU = GetObject(LDAP://OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es,DC=Deve lopment,DC =Group,DC= co,DC=uk)
Row = 1
Do Until Cells(Row, 1) = Empty
gname = Trim(Cells(Row, 1).Value)
sname = Trim(Cells(Row, 2).Value)
ID = Cells(Row, 3).Value
mailingaddress = Cells(Row, 4).Value
city = Cells(Row, 5).Value
postalcode = Cells(Row, 6).Value
homephone = Cells(Row, 7).Value
cellular = Cells(Row, 8).Value
dept = Trim(Cells(Row, 9).Value)
FullName = gname & " " & sname
AliasCount = 2
Alias = LCase(gname & Left(sname, AliasCount))
Set conn = CreateObject("ADODB.Connec tion")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user) (mailNickn ame=" & Alias & "));adspath;subtree"
Set rs = conn.Execute(ldapStr)
While rs.RecordCount > 0
AliasCount = AliasCount + 1
Alias = LCase(gname & Left(sname, AliasCount))
ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user) (mailNickn ame=" & Alias & "));adspath;subtree"
Set rs = conn.Execute(ldapStr)
Wend
' Update User Record
Set oUser = oOU.Create("user", "cn=" & FullName)
oUser.Put "cn", FullName
oUser.Put "SamAccountName", Alias
oUser.Put "userPrincipalName", Alias & "@mycompany.local"
oUser.Put "givenName", gname
oUser.Put "sn", sname
oUser.Put "description", ID
oUser.SetInfo
oUser.GetInfo
' Enable Account
oUser.AccountDisabled = False
' Set Pwd to be same as 123456
oUser.SetPassword ("123456")
'Account is not disabled
oUser.AccountDisabled = False
' User must change password at next Logon
oUser.Put "pwdLastSet", CLng(0)
oUser.SetInfo
Set oMailbox = oUser
MDBName = "Mailbox Store (EXCHANGE)"
StorageGroup = "First Storage Group"
Server = "Exchange"
AdminGroup = "MyCompany"
Organization = "MyCompany School of Arts"
DomainDN = "DC=mycompany,DC=local"
oMailbox.CreateMailbox "LDAP://CN=" & MDBName & _
",CN=" & StorageGroup & _
",CN=InformationStore" & _
",CN=" & Server & _
",CN=Servers" & _
",CN=" & AdminGroup & _
",CN=Administrative Groups" & _
",CN=" & Organization & _
",CN=Microsoft Exchange,CN=Services" & _
",CN=Configuration," & DomainDN
oUser.SetInfo
StrobjGroup1 = "LDAP://CN=" & dept & ",OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es,DC=Deve lopment,DC =Group,DC= co,DC=uk"
Set objGroup1 = GetObject(StrobjGroup1)
objGroup1.Add (oUser.ADsPath)
Set oUser = Nothing
Row = Row + 1
Loop
End Sub
I get this error.
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Website usercreation.vbs
Line: 3
Char: 9
Error: Expected end of statement
Code: 800A0401
Source: Microsoft VBScript compilation error
-------------------------- -
OK
-------------------------- -
Sub CreateUsers()
Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser
Set rootDSE = GetObject(LDAP://RootDSE)
DomainContainer = rootDSE.Get("defaultNaming
Set oOU = GetObject(LDAP://OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
Row = 1
Do Until Cells(Row, 1) = Empty
gname = Trim(Cells(Row, 1).Value)
sname = Trim(Cells(Row, 2).Value)
ID = Cells(Row, 3).Value
mailingaddress = Cells(Row, 4).Value
city = Cells(Row, 5).Value
postalcode = Cells(Row, 6).Value
homephone = Cells(Row, 7).Value
cellular = Cells(Row, 8).Value
dept = Trim(Cells(Row, 9).Value)
FullName = gname & " " & sname
AliasCount = 2
Alias = LCase(gname & Left(sname, AliasCount))
Set conn = CreateObject("ADODB.Connec
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)
Set rs = conn.Execute(ldapStr)
While rs.RecordCount > 0
AliasCount = AliasCount + 1
Alias = LCase(gname & Left(sname, AliasCount))
ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)
Set rs = conn.Execute(ldapStr)
Wend
' Update User Record
Set oUser = oOU.Create("user", "cn=" & FullName)
oUser.Put "cn", FullName
oUser.Put "SamAccountName", Alias
oUser.Put "userPrincipalName", Alias & "@mycompany.local"
oUser.Put "givenName", gname
oUser.Put "sn", sname
oUser.Put "description", ID
oUser.SetInfo
oUser.GetInfo
' Enable Account
oUser.AccountDisabled = False
' Set Pwd to be same as 123456
oUser.SetPassword ("123456")
'Account is not disabled
oUser.AccountDisabled = False
' User must change password at next Logon
oUser.Put "pwdLastSet", CLng(0)
oUser.SetInfo
Set oMailbox = oUser
MDBName = "Mailbox Store (EXCHANGE)"
StorageGroup = "First Storage Group"
Server = "Exchange"
AdminGroup = "MyCompany"
Organization = "MyCompany School of Arts"
DomainDN = "DC=mycompany,DC=local"
oMailbox.CreateMailbox "LDAP://CN=" & MDBName & _
",CN=" & StorageGroup & _
",CN=InformationStore" & _
",CN=" & Server & _
",CN=Servers" & _
",CN=" & AdminGroup & _
",CN=Administrative Groups" & _
",CN=" & Organization & _
",CN=Microsoft Exchange,CN=Services" & _
",CN=Configuration," & DomainDN
oUser.SetInfo
StrobjGroup1 = "LDAP://CN=" & dept & ",OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
Set objGroup1 = GetObject(StrobjGroup1)
objGroup1.Add (oUser.ADsPath)
Set oUser = Nothing
Row = Row + 1
Loop
End Sub
I get this error.
--------------------------
Windows Script Host
--------------------------
Script: C:\Website usercreation.vbs
Line: 3
Char: 9
Error: Expected end of statement
Code: 800A0401
Source: Microsoft VBScript compilation error
--------------------------
OK
--------------------------
Hi,
I will have a look and will get back to you
regards
Chandru
I will have a look and will get back to you
regards
Chandru
ASKER
Ok Chandru...
Rob has already given me a way to create a user with all details from a excel...Just the Mailbox portion is pending...
Rob has already given me a way to create a user with all details from a excel...Just the Mailbox portion is pending...
Can you post the code for the same? So i can work on the same
ASKER
ASKER
Here is the Code...
'====================
' Bind to Active Directory.
Set objRootLDAP = GetObject("LDAP://rootDSE" )
' CONFIGURATION PARAMETERS FOR THE SCRIPT
strExcelFile = Replace(WScript.ScriptFull Name, WScript.ScriptName, "") & "Users_Sharath.xls"
strOUPath = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es," & objRootLDAP.Get("defaultNa mingContex t")
strPassword = "abc123"
' END CONFIGURATION PARAMETERS
Const xlUp = -4162
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Set objExcel = CreateObject("Excel.Applic ation")
objExcel.Visible = True
objExcel.Workbooks.Open strExcelFile
Set objNetwork = CreateObject("WScript.Netw ork")
strDomainName = objNetwork.UserDomain
For intRow = 2 To objExcel.ActiveSheet.Cells (65536, "A").End(xlUp).Row
strFullName = Trim(objExcel.ActiveSheet. Cells(intR ow, "A").Value)
strUserName = Trim(objExcel.ActiveSheet. Cells(intR ow, "B").Value)
strEmail = Trim(objExcel.ActiveSheet. Cells(intR ow, "C").Value)
strManager = Trim(objExcel.ActiveSheet. Cells(intR ow, "D").Value)
strGroups = Trim(objExcel.ActiveSheet. Cells(intR ow, "E").Value)
strTitle = Trim(objExcel.ActiveSheet. Cells(intR ow, "F").Value)
strCompany = Trim(objExcel.ActiveSheet. Cells(intR ow, "G").Value)
strDepartment = Trim(objExcel.ActiveSheet. Cells(intR ow, "H").Value)
strDescription = Trim(objExcel.ActiveSheet. Cells(intR ow, "I").Value)
strOfficePh = Trim(objExcel.ActiveSheet. Cells(intR ow, "J").Value)
strMobilePh = Trim(objExcel.ActiveSheet. Cells(intR ow, "K").Value)
strHomePh = Trim(objExcel.ActiveSheet. Cells(intR ow, "L").Value)
strFirstName = Trim(Left(strFullName, InStrRev(strFullName, " ") - 1))
strLastName = Trim(Mid(strFullName, InStrRev(strFullName, " ") + 1))
If strFullName <> "" And strUserName <> "" And strEmail <> "" Then
MsgBox "About to create:" & VbCrLf &_
strFullName & VbCrLf &_
strFirstName & VbCrLf &_
strLastName & VbCrLf & _
strUserName & VbCrLf &_
strPassword & VbCrLf &_
strManager & VbCrLf &_
"LDAP://" & strOUPath
' This will add the user to eg. Domain.Local\Users
Set objContainer = GetObject("LDAP://" & strOUPath)
' Check if the user already exists
On Error Resume Next
Set objNewUser = GetObject("LDAP://cn=" & strFullName & "," & strOUPath)
If Err.Number = 0 Then
MsgBox "User " & strFullName & " already exists."
On Error GoTo 0
Else
Err.Clear
On Error GoTo 0
' Build the actual User.
' Attributes listed here: http://support.microsoft.com/kb/555638
Set objNewUser = objContainer.Create("User" , "cn= " & strFullName)
'objNewUser.Put "userPrincipalName", strUserName & "@" & Replace(Replace(objRootLDA P.Get("def aultNaming Context"), ",", "."), "DC=", "")
If InStr(strUserName, "@") > 0 Then
arrDomUserName = Split(strUserName, "@")
strUserName = arrDomUserName(0)
strSuffix = arrDomUserName(1)
Else
strUserName = strUserName
strSuffix = Replace(Replace(objRootLDA P.Get("def aultNaming Context"), ",", "."), "DC=", "")
End If
objNewUser.Put "userPrincipalName", strUserName & "@" & strSuffix
objNewUser.Put "sAMAccountName", strUserName
objNewUser.Put "givenName", strFirstName
objNewUser.Put "sn", strLastName
objNewUser.Put "displayName", strFullName
objNewUser.Put "mail", strEmail
If strManager <> "" Then
Set objManager = GetObject(Get_LDAP_User_Pr operties(" user", "samAccountName", strManager, "adsPath"))
objNewUser.Put "manager", Replace(objManager.AdsPath , "LDAP://", "")
Set objManager = Nothing
End If
If strTitle <> "" Then objNewUser.Put "Title", strTitle
If strCompany <> "" Then objNewUser.Put "company", strCompany
If strDepartment <> "" Then objNewUser.Put "department", strDepartment
If strDescription <> "" Then objNewUser.Put "description", strDescription
If strOfficePh <> "" Then objNewUser.Put "telephoneNumber", strOfficePh
If strHomePh <> "" Then objNewUser.Put "homePhone", strHomePh
If strMobilePh <> "" Then objNewUser.Put "mobile", strMobilePh
objNewUser.SetInfo
objNewUser.SetPassword strPassword
objNewUser.AccountDisabled = False
objNewUser.SetInfo
intUserAccountControl = objNewUser.Get("userAccoun tControl")
If Not objNewUser.userAccountCont rol AND ADS_UF_DONT_EXPIRE_PASSWD Then
objNewUser.Put "userAccountControl", objNewUser.userAccountCont rol XOR ADS_UF_DONT_EXPIRE_PASSWD
objNewUser.SetInfo
End If
If strGroups <> "" Then
arrGroups = Split(strGroups, ":")
For Each strGroupName In arrGroups
strGroupPath = Get_LDAP_User_Properties(" group", "cn", strGroupName, "adsPath")
If strGroupPath <> "" Then
Set objGroup = GetObject(strGroupPath)
On Error Resume Next
objGroup.Add objNewUser.AdsPath
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
boolUserAdded = False
arrSid = objNewUser.objectSid
strSidHex = OctetToHexStr(arrSid)
strSidDec = HexSIDtoSDDL(strSidHex)
On Error Resume Next
objGroup.Add "LDAP://<SID=" & strSidDec & ">"
If Err.Number <> 0 Then
boolUserAdded = False
'WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & Replace(objDomUser.AdsPath , "WinNT://", "") & " to " & objGroup.adspath
WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & strSidDec & " to " & objGroup.adspath
Err.Clear
On Error GoTo 0
Else
boolUserAdded = True
End If
Else
boolUserAdded = True
End If
If boolUserAdded = True Then
WScript.Echo "User " & strUserName & " was added to the group " & objGroup.AdsPath
Else
WScript.Echo "Could not add user " & strUserName & " to the group " & strGroupName
End If
Set objGroup = Nothing
Else
WScript.Echo "Could not locate the group " & strGroupName & " to add the user " & objNewUser.samAccountName & " to."
End If
Next
End If
End If
End If
Next
MsgBox "Done"
objExcel.ActiveWorkbook.Cl ose False
objExcel.Quit
Set objExcel = Nothing
Function Get_LDAP_User_Properties(s trObjectTy pe, strSearchField, strObjectToGet, strCommaDelimProps)
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE" )
strDNSDomain = objRootDSE.Get("defaultNam ingContext ")
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Comman d")
Set adoConnection = CreateObject("ADODB.Connec tion")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnectio n = adoConnection
' Filter on user objects.
'strFilter = "(&(objectCategory=person) (objectCla ss=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Pag e Size") = 100
adoCommand.Properties("Tim eout") = 30
adoCommand.Properties("Cac he Results") = False
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
strDetails = adoRecordset.Fields(intCou nt).Value
Else
strDetails = strDetails & VbCrLf & adoRecordset.Fields(intCou nt).Value
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strDetails
End Function
'Function to convert OctetString (byte array) to Hex string.
Function OctetToHexStr(arrbytOctet)
Dim k
OctetToHexStr = ""
For k = 1 To Lenb(arrbytOctet)
OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
Next
End Function
' Function to convert hex Sid to decimal (SDDL) Sid.
Function HexSIDtoSDDL(strHexSID)
Dim i
Dim strA, strB, strC, strD, strE, strF, strG
ReDim arrTemp(Len(strHexSID)/2 - 1)
'Create an array, where each element contains a single byte from the hex number
For i = 0 To UBound(arrTemp)
arrTemp(i) = Mid(strHexSID, 2 * i + 1, 2)
Next
'Move through the array to get each section, then convert it to decimal format
strA = CInt(arrTemp(0))
For i = 0 To UBound(arrTemp) 'Forward cycle for big-endian format
Select Case i
Case 2 strB = strB & arrTemp(i)
Case 3 strB = strB & arrTemp(i)
Case 4 strB = strB & arrTemp(i)
Case 5 strB = strB & arrTemp(i)
Case 6 strB = strB & arrTemp(i)
Case 7 strB = strB & arrTemp(i)
End Select
Next
strB = CInt("&H" & strB)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 11 strC = strC & arrTemp(i)
Case 10 strC = strC & arrTemp(i)
Case 9 strC = strC & arrTemp(i)
Case 8 strC = strC & arrTemp(i)
End Select
Next
strC = CInt("&H" & strC)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 15 strD = strD & arrTemp(i)
Case 14 strD = strD & arrTemp(i)
Case 13 strD = strD & arrTemp(i)
Case 12 strD = strD & arrTemp(i)
End Select
Next
strD = CLng("&H" & strD)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 19 strE = strE & arrTemp(i)
Case 18 strE = strE & arrTemp(i)
Case 17 strE = strE & arrTemp(i)
Case 16 strE = strE & arrTemp(i)
End Select
Next
strE = CLng("&H" & strE)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 23 strF = strF & arrTemp(i)
Case 22 strF = strF & arrTemp(i)
Case 21 strF = strF & arrTemp(i)
Case 20 strF = strF & arrTemp(i)
End Select
Next
strF = CLng("&H" & strF)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 27 strG = strG & arrTemp(i)
Case 26 strG = strG & arrTemp(i)
Case 25 strG = strG & arrTemp(i)
Case 24 strG = strG & arrTemp(i)
End Select
Next
strG = CLng("&H" & strG)
HexSIDtoSDDL = "S-" & strA & "-" & strB & "-" & strC & "-" & strD & "-" & strE & "-" & strF & "-" & strG
End Function
'====================
'====================
' Bind to Active Directory.
Set objRootLDAP = GetObject("LDAP://rootDSE"
' CONFIGURATION PARAMETERS FOR THE SCRIPT
strExcelFile = Replace(WScript.ScriptFull
strOUPath = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
strPassword = "abc123"
' END CONFIGURATION PARAMETERS
Const xlUp = -4162
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Set objExcel = CreateObject("Excel.Applic
objExcel.Visible = True
objExcel.Workbooks.Open strExcelFile
Set objNetwork = CreateObject("WScript.Netw
strDomainName = objNetwork.UserDomain
For intRow = 2 To objExcel.ActiveSheet.Cells
strFullName = Trim(objExcel.ActiveSheet.
strUserName = Trim(objExcel.ActiveSheet.
strEmail = Trim(objExcel.ActiveSheet.
strManager = Trim(objExcel.ActiveSheet.
strGroups = Trim(objExcel.ActiveSheet.
strTitle = Trim(objExcel.ActiveSheet.
strCompany = Trim(objExcel.ActiveSheet.
strDepartment = Trim(objExcel.ActiveSheet.
strDescription = Trim(objExcel.ActiveSheet.
strOfficePh = Trim(objExcel.ActiveSheet.
strMobilePh = Trim(objExcel.ActiveSheet.
strHomePh = Trim(objExcel.ActiveSheet.
strFirstName = Trim(Left(strFullName, InStrRev(strFullName, " ") - 1))
strLastName = Trim(Mid(strFullName, InStrRev(strFullName, " ") + 1))
If strFullName <> "" And strUserName <> "" And strEmail <> "" Then
MsgBox "About to create:" & VbCrLf &_
strFullName & VbCrLf &_
strFirstName & VbCrLf &_
strLastName & VbCrLf & _
strUserName & VbCrLf &_
strPassword & VbCrLf &_
strManager & VbCrLf &_
"LDAP://" & strOUPath
' This will add the user to eg. Domain.Local\Users
Set objContainer = GetObject("LDAP://" & strOUPath)
' Check if the user already exists
On Error Resume Next
Set objNewUser = GetObject("LDAP://cn=" & strFullName & "," & strOUPath)
If Err.Number = 0 Then
MsgBox "User " & strFullName & " already exists."
On Error GoTo 0
Else
Err.Clear
On Error GoTo 0
' Build the actual User.
' Attributes listed here: http://support.microsoft.com/kb/555638
Set objNewUser = objContainer.Create("User"
'objNewUser.Put "userPrincipalName", strUserName & "@" & Replace(Replace(objRootLDA
If InStr(strUserName, "@") > 0 Then
arrDomUserName = Split(strUserName, "@")
strUserName = arrDomUserName(0)
strSuffix = arrDomUserName(1)
Else
strUserName = strUserName
strSuffix = Replace(Replace(objRootLDA
End If
objNewUser.Put "userPrincipalName", strUserName & "@" & strSuffix
objNewUser.Put "sAMAccountName", strUserName
objNewUser.Put "givenName", strFirstName
objNewUser.Put "sn", strLastName
objNewUser.Put "displayName", strFullName
objNewUser.Put "mail", strEmail
If strManager <> "" Then
Set objManager = GetObject(Get_LDAP_User_Pr
objNewUser.Put "manager", Replace(objManager.AdsPath
Set objManager = Nothing
End If
If strTitle <> "" Then objNewUser.Put "Title", strTitle
If strCompany <> "" Then objNewUser.Put "company", strCompany
If strDepartment <> "" Then objNewUser.Put "department", strDepartment
If strDescription <> "" Then objNewUser.Put "description", strDescription
If strOfficePh <> "" Then objNewUser.Put "telephoneNumber", strOfficePh
If strHomePh <> "" Then objNewUser.Put "homePhone", strHomePh
If strMobilePh <> "" Then objNewUser.Put "mobile", strMobilePh
objNewUser.SetInfo
objNewUser.SetPassword strPassword
objNewUser.AccountDisabled
objNewUser.SetInfo
intUserAccountControl = objNewUser.Get("userAccoun
If Not objNewUser.userAccountCont
objNewUser.Put "userAccountControl", objNewUser.userAccountCont
objNewUser.SetInfo
End If
If strGroups <> "" Then
arrGroups = Split(strGroups, ":")
For Each strGroupName In arrGroups
strGroupPath = Get_LDAP_User_Properties("
If strGroupPath <> "" Then
Set objGroup = GetObject(strGroupPath)
On Error Resume Next
objGroup.Add objNewUser.AdsPath
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
boolUserAdded = False
arrSid = objNewUser.objectSid
strSidHex = OctetToHexStr(arrSid)
strSidDec = HexSIDtoSDDL(strSidHex)
On Error Resume Next
objGroup.Add "LDAP://<SID=" & strSidDec & ">"
If Err.Number <> 0 Then
boolUserAdded = False
'WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & Replace(objDomUser.AdsPath
WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & strSidDec & " to " & objGroup.adspath
Err.Clear
On Error GoTo 0
Else
boolUserAdded = True
End If
Else
boolUserAdded = True
End If
If boolUserAdded = True Then
WScript.Echo "User " & strUserName & " was added to the group " & objGroup.AdsPath
Else
WScript.Echo "Could not add user " & strUserName & " to the group " & strGroupName
End If
Set objGroup = Nothing
Else
WScript.Echo "Could not locate the group " & strGroupName & " to add the user " & objNewUser.samAccountName & " to."
End If
Next
End If
End If
End If
Next
MsgBox "Done"
objExcel.ActiveWorkbook.Cl
objExcel.Quit
Set objExcel = Nothing
Function Get_LDAP_User_Properties(s
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE"
strDNSDomain = objRootDSE.Get("defaultNam
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Comman
Set adoConnection = CreateObject("ADODB.Connec
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnectio
' Filter on user objects.
'strFilter = "(&(objectCategory=person)
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Pag
adoCommand.Properties("Tim
adoCommand.Properties("Cac
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
strDetails = adoRecordset.Fields(intCou
Else
strDetails = strDetails & VbCrLf & adoRecordset.Fields(intCou
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strDetails
End Function
'Function to convert OctetString (byte array) to Hex string.
Function OctetToHexStr(arrbytOctet)
Dim k
OctetToHexStr = ""
For k = 1 To Lenb(arrbytOctet)
OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet,
Next
End Function
' Function to convert hex Sid to decimal (SDDL) Sid.
Function HexSIDtoSDDL(strHexSID)
Dim i
Dim strA, strB, strC, strD, strE, strF, strG
ReDim arrTemp(Len(strHexSID)/2 - 1)
'Create an array, where each element contains a single byte from the hex number
For i = 0 To UBound(arrTemp)
arrTemp(i) = Mid(strHexSID, 2 * i + 1, 2)
Next
'Move through the array to get each section, then convert it to decimal format
strA = CInt(arrTemp(0))
For i = 0 To UBound(arrTemp) 'Forward cycle for big-endian format
Select Case i
Case 2 strB = strB & arrTemp(i)
Case 3 strB = strB & arrTemp(i)
Case 4 strB = strB & arrTemp(i)
Case 5 strB = strB & arrTemp(i)
Case 6 strB = strB & arrTemp(i)
Case 7 strB = strB & arrTemp(i)
End Select
Next
strB = CInt("&H" & strB)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 11 strC = strC & arrTemp(i)
Case 10 strC = strC & arrTemp(i)
Case 9 strC = strC & arrTemp(i)
Case 8 strC = strC & arrTemp(i)
End Select
Next
strC = CInt("&H" & strC)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 15 strD = strD & arrTemp(i)
Case 14 strD = strD & arrTemp(i)
Case 13 strD = strD & arrTemp(i)
Case 12 strD = strD & arrTemp(i)
End Select
Next
strD = CLng("&H" & strD)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 19 strE = strE & arrTemp(i)
Case 18 strE = strE & arrTemp(i)
Case 17 strE = strE & arrTemp(i)
Case 16 strE = strE & arrTemp(i)
End Select
Next
strE = CLng("&H" & strE)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 23 strF = strF & arrTemp(i)
Case 22 strF = strF & arrTemp(i)
Case 21 strF = strF & arrTemp(i)
Case 20 strF = strF & arrTemp(i)
End Select
Next
strF = CLng("&H" & strF)
For i = UBound(arrTemp) To 0 Step -1 'Reverse cycle for little-endian format
Select Case i
Case 27 strG = strG & arrTemp(i)
Case 26 strG = strG & arrTemp(i)
Case 25 strG = strG & arrTemp(i)
Case 24 strG = strG & arrTemp(i)
End Select
Next
strG = CLng("&H" & strG)
HexSIDtoSDDL = "S-" & strA & "-" & strB & "-" & strC & "-" & strD & "-" & strE & "-" & strF & "-" & strG
End Function
'====================
Sharath, a few posts back, in post ID: 19990655, you had this error:
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Website usercreation.vbs
Line: 3
Char: 9
Error: Expected end of statement
Code: 800A0401
Source: Microsoft VBScript compilation error
-------------------------- -
OK
-------------------------- -
That refers to these three lines at the top:
Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser
and the "As datatype" property is not supported in VBScript. Also, judging by the direct "Cells" references in that code, this is not a VBS file at all. It is designed to be run directly from an Excel macro.
Paste it into an Excel module and see how it goes...
Regards,
Rob.
--------------------------
Windows Script Host
--------------------------
Script: C:\Website usercreation.vbs
Line: 3
Char: 9
Error: Expected end of statement
Code: 800A0401
Source: Microsoft VBScript compilation error
--------------------------
OK
--------------------------
That refers to these three lines at the top:
Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser
and the "As datatype" property is not supported in VBScript. Also, judging by the direct "Cells" references in that code, this is not a VBS file at all. It is designed to be run directly from an Excel macro.
Paste it into an Excel module and see how it goes...
Regards,
Rob.
ASKER
Rob does this mean that this is a macro.
ID: 19991951
How should the file Headers look like.As mentioned in the links the text is there but not able to understand what they are...
ID: 19991951
How should the file Headers look like.As mentioned in the links the text is there but not able to understand what they are...
Yes, it will be a macro....as far as I can tell, these give clues on the headers:
gname = Trim(Cells(Row, 1).Value)
sname = Trim(Cells(Row, 2).Value)
ID = Cells(Row, 3).Value
mailingaddress = Cells(Row, 4).Value
city = Cells(Row, 5).Value
postalcode = Cells(Row, 6).Value
homephone = Cells(Row, 7).Value
cellular = Cells(Row, 8).Value
dept = Trim(Cells(Row, 9).Value)
where the 1, 2, 3, 4, 5, 6, 7, 8, 9 specify the column fields.
Rob.
gname = Trim(Cells(Row, 1).Value)
sname = Trim(Cells(Row, 2).Value)
ID = Cells(Row, 3).Value
mailingaddress = Cells(Row, 4).Value
city = Cells(Row, 5).Value
postalcode = Cells(Row, 6).Value
homephone = Cells(Row, 7).Value
cellular = Cells(Row, 8).Value
dept = Trim(Cells(Row, 9).Value)
where the 1, 2, 3, 4, 5, 6, 7, 8, 9 specify the column fields.
Rob.
I would suggest creating a new Excel spreadsheet. Don't modify the existing one you have just yet....
Regards,
Rob.
Regards,
Rob.
ASKER
Rob i have put the code in the new Module...
I have created the data in the excel..
How do i run it...
When i go to Run macro i dont see the macro name to run...
I have created the data in the excel..
How do i run it...
When i go to Run macro i dont see the macro name to run...
Are you sure you've got these lines
Sub CreateUsers()
...
' rest of code
...
End Sub
Also, make sure the new module you have inserted was created by opening the Visual Basic Editor (press ALT + F11), right click ThisWorkbook on the left, and click Insert --> Module, then paste the code on the right in the main window/
Regards,
Rob.
Sub CreateUsers()
...
' rest of code
...
End Sub
Also, make sure the new module you have inserted was created by opening the Visual Basic Editor (press ALT + F11), right click ThisWorkbook on the left, and click Insert --> Module, then paste the code on the right in the main window/
Regards,
Rob.
ASKER
Yes Rob got it i copied the wrong code.
I get this...
-------------------------- -
Microsoft Visual Basic
-------------------------- -
Compile error:
I have taken the code from
ID: 19990655
User-defined type not defined
-------------------------- -
OK Help
-------------------------- -
I get this...
--------------------------
Microsoft Visual Basic
--------------------------
Compile error:
I have taken the code from
ID: 19990655
User-defined type not defined
--------------------------
OK Help
--------------------------
If you click Debug, which line is highlighted for User Type Not Defined?
Rob.
Rob.
ASKER
Its highlighting these 2 lines
Sub CreateUsers()
Dim oMailbox As CDOEXM.IMailboxStore
Sub CreateUsers()
Dim oMailbox As CDOEXM.IMailboxStore
Hi Sharath / Rob,
I think this would this would really help. The script that will really suit your needs
Option Explicit
On Error Resume Next
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "DC1"
strOU = "OU=OUName"
strUserFileName = "NewUsers.csv"
strPassword = "D0ntCh8ngeTh1s"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fileout= fs.OpenTextFile(strlogfile ,8,True)
If fs.fileexists(strUserFileN ame) Then
Set filein = fs.OpenTextFile(strUserFil eName, 1)
Else
fileout.writeline:fileout. writeline( "!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!")
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem opening the New_users file. Make sure the " & strUserFileName & " file exists!")
fileout.writeline
fileout.writeline("!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!")
WScript.Quit
End If
fileout.writeline:fileout. writeline( "********* ********** ********** ********** ********** ********** ********** ********** ******")
fileout.writeline("Beginni ng creation of new users and mailboxes on " & Now)
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil eName, 1, -1)
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), "§", -1, 1)
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE" )
strDomainDN = iAdRootDSE.Get("defaultNam ingContext ")
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha ngeServer" )
Set objSG = CreateObject("CDOEXM.Stora geGroup")
Set objMSDB = CreateObject("CDOEXM.Mailb oxStoreDB" )
Set iDS = objServer.GetInterface("ID ataSource" )
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName) = False Or ValidateName(strSurname) = False Then
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ########################## ########## ########## ########## ########## ########## ######
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs er, strLDAPUrl)
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval )
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval )
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName & " " & strGivenName & " " & strAlias)
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
fileout.writeline("******* ********** ********** ********** ********** ********** ********** ********** ********")
MsgBox("Done")
' Exit the application.
wscript.Quit
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
' Get the container.
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUserMailbox(objUs er, strLDAPUrl)
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl" , 2
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm lhttp")
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr iptor")
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H 20014,0,0, 1,0,0 '&H20014 -> gives Read permissions
AddAce dacl,strExternalAccount,&H 100,5,0,1, "{AB721A54 -1E2F-11D0 -9819-00AA 0040529B}" ,0 '&H100 & the string -> enables the Send As permissions
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr ay(oSecuri tyDescript or)
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13 1079,0,2,0 ,0,0
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro lEntry")
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType) <> "0" Then
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
Sharath, can you give it a try......
regards
Chandru
I think this would this would really help. The script that will really suit your needs
Option Explicit
On Error Resume Next
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "DC1"
strOU = "OU=OUName"
strUserFileName = "NewUsers.csv"
strPassword = "D0ntCh8ngeTh1s"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi
Set fileout= fs.OpenTextFile(strlogfile
If fs.fileexists(strUserFileN
Set filein = fs.OpenTextFile(strUserFil
Else
fileout.writeline:fileout.
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem
fileout.writeline
fileout.writeline("!!!!!!!
WScript.Quit
End If
fileout.writeline:fileout.
fileout.writeline("Beginni
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE"
strDomainDN = iAdRootDSE.Get("defaultNam
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha
Set objSG = CreateObject("CDOEXM.Stora
Set objMSDB = CreateObject("CDOEXM.Mailb
Set iDS = objServer.GetInterface("ID
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName)
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ##########################
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ##########################
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ##########################
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ##########################
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ##########################
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio
fileout.writeline("*******
MsgBox("Done")
' Exit the application.
wscript.Quit
'/////////////////////////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'/////////////////////////
Function CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
' Get the container.
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'/////////////////////////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'/////////////////////////
Function CreateNewUserMailbox(objUs
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl"
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'/////////////////////////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'/////////////////////////
Function CreateMailboxFolders(strEx
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'/////////////////////////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'/////////////////////////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'/////////////////////////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'/////////////////////////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H
AddAce dacl,strExternalAccount,&H
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'/////////////////////////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'/////////////////////////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'/////////////////////////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType)
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
Sharath, can you give it a try......
regards
Chandru
ASKER
Chandru is this a Vba file...
What are the changes i need to do in this...
What are the changes i need to do in this...
ASKER
I just created a csv file and i got this...
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/3/2007 1:07:57 PM
The input line for user n° 1 has an incorrect syntax
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/3/2007 1:08:01 PM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
How should the Csv file be?
**************************
Beginning creation of new users and mailboxes on 10/3/2007 1:07:57 PM
The input line for user n° 1 has an incorrect syntax
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/3/2007 1:08:01 PM: 2 users processed.
**************************
How should the Csv file be?
Here is the csv file format....
Alias,First Name,Last Name,CompanyName,Departmen t,Telephon e number,Exchange Server,First Storage Group,Mailbox Store,Domain Name,email address
Alias,First Name,Last Name,CompanyName,Departmen
ASKER
Chandru
I have changed these parts.
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = False
The csv is as you mentioned...
Still get this message..
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/3/2007 1:27:31 PM
The input line for user n° 1 has an incorrect syntax
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/3/2007 1:27:35 PM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
I have changed these parts.
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = False
The csv is as you mentioned...
Still get this message..
**************************
Beginning creation of new users and mailboxes on 10/3/2007 1:27:31 PM
The input line for user n° 1 has an incorrect syntax
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/3/2007 1:27:35 PM: 2 users processed.
**************************
Can i try in my setup and get back to you?
ASKER
Ok...Thanks...
Hey guys, just a quick note from quickly looking at it, where Sharath is getting that error, the script is expecting 10 arguments to be passed to it....Chandru, if that makes sense to you, that might be the first place to look....
Rob.
Rob.
ASKER
Rob any way to tell which are the lines to change...
Sharath, the CSV format that Chandru listed is correct, however, by the look of this line:
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), "§", -1, 1)
I would say that the delimiter is not a comma, it is that "§" symbol, so in your CSV file, open it with notepad, and change the Field delimiter to that symbol, and try again.....
Regards,
Rob.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
I would say that the delimiter is not a comma, it is that "§" symbol, so in your CSV file, open it with notepad, and change the Field delimiter to that symbol, and try again.....
Regards,
Rob.
ASKER
Rob now a different one...
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/4/2007 12:19:54 PM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/4/2007 12:19:58 PM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
**************************
Beginning creation of new users and mailboxes on 10/4/2007 12:19:54 PM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/4/2007 12:19:58 PM: 2 users processed.
**************************
ASKER
Where should i mention the exchange,Storage name?
The field "First Storage Group", which is the 8th field.
That should be the exact name of one of your storage groups.
Rob.
That should be the exact name of one of your storage groups.
Rob.
ASKER
Rob should i change these line according to my domain?
Option Explicit
On Error Resume Next
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
If yes then how?
Ex:
Dim str First storage ' As String
Option Explicit
On Error Resume Next
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
If yes then how?
Ex:
Dim str First storage ' As String
No, they are just variable declarations, which automatically get filled (through the rest of the script) from the values that you put in your text file. See here:
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
around about line 120 or so, is where it splits the info from the file into those values, so you wouldn't need to change anything.....
Regards,
Rob.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
around about line 120 or so, is where it splits the info from the file into those values, so you wouldn't need to change anything.....
Regards,
Rob.
ASKER
Rob sorry can you please paste the lines that i need to change :)
You shouldn't need to change any.....all you need to do is make sure that your CSV file contains the correct data for your environment....
Rob.
Rob.
ASKER
I have this in the csv file.
Ram§Sharath§Ramesh§Company name§State §234624564 §Exchanges ervername§ Storage Group§Travel§Domain§Sharat h.adsfadf@ plc.com
Is this correct
Ram§Sharath§Ramesh§Company
Is this correct
Yeah, but not if it is exactly
§Exchangeservername§Storag e Group§Travel§Domain§
those values should be the actual display names of the exchange server, a storage group on that exchange server (usually something like "First Storage Group", the mailbox store name, and the domain.
Regards,
Rob.
§Exchangeservername§Storag
those values should be the actual display names of the exchange server, a storage group on that exchange server (usually something like "First Storage Group", the mailbox store name, and the domain.
Regards,
Rob.
ASKER
YEs Rob all the details are exact but still get this error.
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/4/2007 12:54:37 PM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/4/2007 12:54:41 PM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
**************************
Beginning creation of new users and mailboxes on 10/4/2007 12:54:37 PM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/4/2007 12:54:41 PM: 2 users processed.
**************************
Actually, it looks like it's not finding any storage groups for your Exchange Server name.....
Under this line:
For Each storegroup In objServer.StorageGroups
please put this line, to see if it's getting that far....
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchangeServer
Regards,
Rob.
Under this line:
For Each storegroup In objServer.StorageGroups
please put this line, to see if it's getting that far....
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchangeServer
Regards,
Rob.
ASKER
Rob i have placed the code as informed .But still get the error.
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/5/2007 8:11:32 AM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 8:11:36 AM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
**************************
Beginning creation of new users and mailboxes on 10/5/2007 8:11:32 AM
Beginning creation of Sharath Ramesh
An error occurred opening the specified storage group.
Error: 0x1A8 Object required
The specified mailbox store could not be found.
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 8:11:36 AM: 2 users processed.
**************************
OK, let's comment out the On Error Resume Next and see where the error is...please post the line you get the error on....
Rob.
Rob.
ASKER
Rob,
I have " On Error Resume Next" in say 5 places should i comment all.
I have " On Error Resume Next" in say 5 places should i comment all.
ASKER
I commented the first one on the top and got this
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 148
Char: 19
Error: ActiveX component can't create object: 'CDOEXM.ExchangeServer'
Code: 800A01AD
Source: Microsoft VBScript runtime error
-------------------------- -
OK
-------------------------- -
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 148
Char: 19
Error: ActiveX component can't create object: 'CDOEXM.ExchangeServer'
Code: 800A01AD
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Right, there we go....you need to have Exchange Management Tools installed:
http://technet.microsoft.com/en-us/library/aa996691.aspx
Regards,
Rob.
http://technet.microsoft.com/en-us/library/aa996691.aspx
Regards,
Rob.
ASKER
Rob i am running this on the exchange itself now.
I get this...
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 158
Char: 1
Error: Variable is undefined: 'strExchangeServer'
Code: 800A01F4
Source: Microsoft VBScript runtime error
-------------------------- -
OK
-------------------------- -
I get this...
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 158
Char: 1
Error: Variable is undefined: 'strExchangeServer'
Code: 800A01F4
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Ooops, that was on the new line that I got you to put in:
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchangeServer
should be:
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
Rob.
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchangeServer
should be:
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
Rob.
ASKER
I get this...
-------------------------- -
Windows Script Host
-------------------------- -
Attempting to open Storaget Group: CN=First Storage Group,CN=InformationStore, CN=INEXCHA NGE1,CN=Se rvers,CN=F irst Administrative Group,CN=Administrative Groups,CN=Group,CN=Microso ft Exchange,CN=Services,CN=Co nfiguratio n,DC=Group ,DC=co,DC= uk on server: Inexchange1
-------------------------- -
OK
-------------------------- -
-------------------------- -
Windows Script Host
-------------------------- -
Attempting to open Storaget Group: CN=Second Storage Group,CN=InformationStore, CN=INEXCHA NGE1,CN=Se rvers,CN=F irst Administrative Group,CN=Administrative Groups,CN=Group,CN=Microso ft Exchange,CN=Services,CN=Co nfiguratio n,DC=Group ,DC=co,DC= uk on server: Inexchange1
-------------------------- -
OK
-------------------------- -
-------------------------- -
-------------------------- -
Done
-------------------------- -
OK
-------------------------- -
After all the 3 messages i get this message in the log file
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/5/2007 8:51:48 AM
Beginning creation of Sharath Ramesh
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 8:52:26 AM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
--------------------------
Windows Script Host
--------------------------
Attempting to open Storaget Group: CN=First Storage Group,CN=InformationStore,
--------------------------
OK
--------------------------
--------------------------
Windows Script Host
--------------------------
Attempting to open Storaget Group: CN=Second Storage Group,CN=InformationStore,
--------------------------
OK
--------------------------
--------------------------
--------------------------
Done
--------------------------
OK
--------------------------
After all the 3 messages i get this message in the log file
**************************
Beginning creation of new users and mailboxes on 10/5/2007 8:51:48 AM
Beginning creation of Sharath Ramesh
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 8:52:26 AM: 2 users processed.
**************************
OK, so we're now down to about line 400.....on about line 368. just under that On Error Resume Next, put in
On Error GoTo 0
which will start displaying errors. Flag this for deletion later when it starts working.
Then, with that in, post the error you get this time...
Rob.
On Error GoTo 0
which will start displaying errors. Flag this for deletion later when it starts working.
Then, with that in, post the error you get this time...
Rob.
ASKER
Rob the 2nd line is On error resume just below it i pasted the code.
I get this now.
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 155
Char: 19
Error: The RPC server is unavailable.
Facility: Win32
ID no: c00706ba
Microsoft CDO for Exchange Management
Code: 8000FFFF
Source: (null)
-------------------------- -
OK
-------------------------- -
After this when i ran it just shows the storage path and come as Done.In the log i get the same error.
I get this now.
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 155
Char: 19
Error: The RPC server is unavailable.
Facility: Win32
ID no: c00706ba
Microsoft CDO for Exchange Management
Code: 8000FFFF
Source: (null)
--------------------------
OK
--------------------------
After this when i ran it just shows the storage path and come as Done.In the log i get the same error.
Hmmm, I wonder why that's back on line 155? Odd.....I'm going on lunch, back soon.
Wait....you need to change these values:
strDCServerName = "DC1"
strOU = "OU=OUName"
at around line 60, to match (a) the server name of your DC, and (b) the OU path that you want to create the user in, in the AD. This will actually create the User in the AD....
Regards,
Rob.
Wait....you need to change these values:
strDCServerName = "DC1"
strOU = "OU=OUName"
at around line 60, to match (a) the server name of your DC, and (b) the OU path that you want to create the user in, in the AD. This will actually create the User in the AD....
Regards,
Rob.
ASKER
Rob i already have set them...
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
Now i dont get that error. I just get the [previously pasted " Attempting to open " 2 times for storages and then Done.Just the error message in the log file as mentioned above.
I have the first 3 line like this...
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
Now i dont get that error. I just get the [previously pasted " Attempting to open " 2 times for storages and then Done.Just the error message in the log file as mentioned above.
I have the first 3 line like this...
Option Explicit
'On Error Resume Next
On Error GoTo 0
Does your log file have any more info in it? From what I can see, just befoer "Done" there are a couple of WriteLines that should add
Creation of users and mailboxes ended on <date>: <number> users processed.
Rob.
Creation of users and mailboxes ended on <date>: <number> users processed.
Rob.
ASKER
No rob that the only data the log file has...
Can you explain this part please...
Creation of users and mailboxes ended on <date>: <number> users processed.
I have this in the csv file.
Ba§Sharath§Ramesh§Comp§Che nnai§23462 4564§Inexc hange1§Sec ond Storage Group§CIO Services§Development§Shara th.ramesh@ tplc.com
Can you explain this part please...
Creation of users and mailboxes ended on <date>: <number> users processed.
I have this in the csv file.
Ba§Sharath§Ramesh§Comp§Che
OK, if we go from a "clean slate", delete the user object from the AD that you are trying to create, and any mail file (alternatively change the name details to that of a test account), then run the script again.
That line I quoted:
>> Creation of users and mailboxes ended on <date>: <number> users processed
should be in the log file at the end, after it has run successfully.
@ Chandru, are you still around? I could use your help with being able to test it in your environment....
Regards,
Rob.
That line I quoted:
>> Creation of users and mailboxes ended on <date>: <number> users processed
should be in the log file at the end, after it has run successfully.
@ Chandru, are you still around? I could use your help with being able to test it in your environment....
Regards,
Rob.
ASKER
Rob there is no user or mailbox that's there in ADS that's created by the script.
I have changed the names in the csv file and tryed.
I get the same mesaage.
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/5/2007 11:11:53 AM
Beginning creation of harish Chandra
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 11:12:03 AM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
Do you mean this line in the script.
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
It is not Quoted...
I have changed the names in the csv file and tryed.
I get the same mesaage.
**************************
Beginning creation of new users and mailboxes on 10/5/2007 11:11:53 AM
Beginning creation of harish Chandra
... Error creating user object
... Error: 424 Object required
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 11:12:03 AM: 2 users processed.
**************************
Do you mean this line in the script.
fileout.writeline("Creatio
It is not Quoted...
Yeah, that line is fine, you can see that the last line in your log file is that line, which is fine.
It should error out before getting to the
... Error creating user object
At about line 368, you will see these lines:
On Error Resume Next
CreateNewUser = False
Can you please add On Error Goto 0 in the middle of those so it looks like this:
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
then run again?
Regards,
Rob.
It should error out before getting to the
... Error creating user object
At about line 368, you will see these lines:
On Error Resume Next
CreateNewUser = False
Can you please add On Error Goto 0 in the middle of those so it looks like this:
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
then run again?
Regards,
Rob.
ASKER
I get this now...
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 383
Char: 5
Error: There is no such object on the server.
Code: 80072030
Source: (null)
-------------------------- -
OK
-------------------------- -
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 383
Char: 5
Error: There is no such object on the server.
Code: 80072030
Source: (null)
--------------------------
OK
--------------------------
Right, so that's most likely this line, with finding the OU container:
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
This isn't going to be a cross-domain issue again is it? Is it on the same domain?
Regards,
Rob.
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
This isn't going to be a cross-domain issue again is it? Is it on the same domain?
Regards,
Rob.
ASKER
Are you talking about exchange.
Yes exchange is in the same domain...
Yes exchange is in the same domain...
What about the DC that it is connecting to on the AD?
Around line 383, change those lines there to this:
' Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
which just adds one line to the middle of what's already there. Run again, and see if the OU path is correct.....we may run a small separate VBS to verify the existence of that object...
Rob.
Around line 383, change those lines there to this:
' Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
which just adds one line to the middle of what's already there. Run again, and see if the OU path is correct.....we may run a small separate VBS to verify the existence of that object...
Rob.
ASKER
Changing these 4lines
' Get the container.
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
With the mentioned?
' Get the container.
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
With the mentioned?
ASKER
I changed the bove lines to this...
Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
And i get this...
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 382
Char: 3
Error: Expected statement
Code: 800A0400
Source: Microsoft VBScript compilation error
-------------------------- -
OK
-------------------------- -
Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
And i get this...
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 382
Char: 3
Error: Expected statement
Code: 800A0400
Source: Microsoft VBScript compilation error
--------------------------
OK
--------------------------
Do you still have
Get the container
commented out? It should have an apostrophe in front of it...
Rob.
Get the container
commented out? It should have an apostrophe in front of it...
Rob.
Oh, and leave these two lines there:
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
Rob.
' Initialize the user object.
Set objUser = objContainer.Create("User"
Rob.
ASKER
Rob i get this...
-------------------------- -
Windows Script Host
-------------------------- -
Attempting to connect to: LDAP://indc01/OU=Named Accounts,DC=Development,DC =Group,DC= co,DC=uk
-------------------------- -
OK
-------------------------- -
Then this error.
-------------------------- -
Windows Script Host
-------------------------- -
Script: C:\Chandru User.vbs
Line: 384
Char: 5
Error: There is no such object on the server.
Code: 80072030
Source: (null)
-------------------------- -
OK
-------------------------- -
named OU is inside many OU's should i specify the full path
--------------------------
Windows Script Host
--------------------------
Attempting to connect to: LDAP://indc01/OU=Named Accounts,DC=Development,DC
--------------------------
OK
--------------------------
Then this error.
--------------------------
Windows Script Host
--------------------------
Script: C:\Chandru User.vbs
Line: 384
Char: 5
Error: There is no such object on the server.
Code: 80072030
Source: (null)
--------------------------
OK
--------------------------
named OU is inside many OU's should i specify the full path
Yes, absolutely! Again, you'll need to specify that in reverse order. So strOU should be:
strOU = "OU=Named Accounts,OU=Departments,OU =Sites"
which would equate to
development.group.co.uk/Si tes/Depart ments/Name d Accounts
Regards,
Rob.
strOU = "OU=Named Accounts,OU=Departments,OU
which would equate to
development.group.co.uk/Si
Regards,
Rob.
ASKER
Ha Rob...Now it has created the user and mail box....
Oh wow! Nice one!
So the mailbox got created without errors? Awesome, so we're done? Can you post the full code for mine and Chandru's reference?
Thanks,
Rob.
So the mailbox got created without errors? Awesome, so we're done? Can you post the full code for mine and Chandru's reference?
Thanks,
Rob.
ASKER
I get this now...
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/5/2007 12:40:00 PM
Beginning creation of harish Chandra
... Succesfully created user.
... Succesfully created mailbox.
... Succesfully added the 'Read' & 'Send As' permissions to the account.
... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: Invalid Argument.
ID no: c103071f
Microsoft CDO for Exchange Management
(-2147024809).
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 12:40:22 PM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
Will it take time to reflect in exchange (Mailbox)
What all should i remove from the script.
Cant the symbol be changed to "," for the csv format
**************************
Beginning creation of new users and mailboxes on 10/5/2007 12:40:00 PM
Beginning creation of harish Chandra
... Succesfully created user.
... Succesfully created mailbox.
... Succesfully added the 'Read' & 'Send As' permissions to the account.
... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: Invalid Argument.
ID no: c103071f
Microsoft CDO for Exchange Management
(-2147024809).
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/5/2007 12:40:22 PM: 2 users processed.
**************************
Will it take time to reflect in exchange (Mailbox)
What all should i remove from the script.
Cant the symbol be changed to "," for the csv format
I do believe it will take some time to reflect in Exchange. I have no idea what you can remove from the script, because I've never tested it, and don't know what's beiing used. I will look at whether we can change the CSV to comma's on Monday. I'm off home for the weekend now.
At least we got somewhere ;-)
Rob.
At least we got somewhere ;-)
Rob.
ASKER
Ok Rob thanks a lot .have a great weekend....
ASKER
Rob/Chandru,
Here is the code which worked...
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fileout= fs.OpenTextFile(strlogfile ,8,True)
If fs.fileexists(strUserFileN ame) Then
Set filein = fs.OpenTextFile(strUserFil eName, 1)
Else
fileout.writeline:fileout. writeline( "!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!")
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem opening the New_users file. Make sure the " & strUserFileName & " file exists!")
fileout.writeline
fileout.writeline("!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!")
WScript.Quit
End If
fileout.writeline:fileout. writeline( "********* ********** ********** ********** ********** ********** ********** ********** ******")
fileout.writeline("Beginni ng creation of new users and mailboxes on " & Now)
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil eName, 1, -1)
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), "§", -1, 1)
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE" )
strDomainDN = iAdRootDSE.Get("defaultNam ingContext ")
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha ngeServer" )
Set objSG = CreateObject("CDOEXM.Stora geGroup")
Set objMSDB = CreateObject("CDOEXM.Mailb oxStoreDB" )
Set iDS = objServer.GetInterface("ID ataSource" )
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName) = False Or ValidateName(strSurname) = False Then
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ########################## ########## ########## ########## ########## ########## ######
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs er, strLDAPUrl)
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval )
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval )
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName & " " & strGivenName & " " & strAlias)
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
fileout.writeline("******* ********** ********** ********** ********** ********** ********** ********** ********")
MsgBox("Done")
' Exit the application.
wscript.Quit
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUserMailbox(objUs er, strLDAPUrl)
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl" , 2
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm lhttp")
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr iptor")
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H 20014,0,0, 1,0,0 '&H20014 -> gives Read permissions
AddAce dacl,strExternalAccount,&H 100,5,0,1, "{AB721A54 -1E2F-11D0 -9819-00AA 0040529B}" ,0 '&H100 & the string -> enables the Send As permissions
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr ay(oSecuri tyDescript or)
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13 1079,0,2,0 ,0,0
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro lEntry")
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType) <> "0" Then
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
Required a bit of tuning .
Chandru please check and help if possible this weekend...
Here is the code which worked...
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi
Set fileout= fs.OpenTextFile(strlogfile
If fs.fileexists(strUserFileN
Set filein = fs.OpenTextFile(strUserFil
Else
fileout.writeline:fileout.
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem
fileout.writeline
fileout.writeline("!!!!!!!
WScript.Quit
End If
fileout.writeline:fileout.
fileout.writeline("Beginni
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE"
strDomainDN = iAdRootDSE.Get("defaultNam
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha
Set objSG = CreateObject("CDOEXM.Stora
Set objMSDB = CreateObject("CDOEXM.Mailb
Set iDS = objServer.GetInterface("ID
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName)
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ##########################
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ##########################
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ##########################
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ##########################
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ##########################
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio
fileout.writeline("*******
MsgBox("Done")
' Exit the application.
wscript.Quit
'/////////////////////////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'/////////////////////////
Function CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'/////////////////////////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'/////////////////////////
Function CreateNewUserMailbox(objUs
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl"
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'/////////////////////////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'/////////////////////////
Function CreateMailboxFolders(strEx
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'/////////////////////////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'/////////////////////////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'/////////////////////////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'/////////////////////////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H
AddAce dacl,strExternalAccount,&H
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'/////////////////////////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'/////////////////////////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'/////////////////////////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType)
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
Required a bit of tuning .
Chandru please check and help if possible this weekend...
Hi Guys,
I think you are almost done. Let me have a look and see
I think you are almost done. Let me have a look and see
Hi Sharath,
Can you change this line "CreateMailboxFolder = False"
to the below
"CreateMailboxFolder = True"
This is the one which creates the mailbox in the exchange server. If not the mailbox will be created normally when the user logs on the first time
We need to also strip out some of the code. I will work on the final code you have pasted and will paste the final code
regards
Chandru
Can you change this line "CreateMailboxFolder = False"
to the below
"CreateMailboxFolder = True"
This is the one which creates the mailbox in the exchange server. If not the mailbox will be created normally when the user logs on the first time
We need to also strip out some of the code. I will work on the final code you have pasted and will paste the final code
regards
Chandru
Hi Sharath,
Here is the final code.............
1) Create a new AD User
2) Create a mailbox for this user
3) Create the physical mailbox on the Exchange server (optional, not necessary for this script to work)
'Create script
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es"
strUserFileName = "NewUsers.csv"
strPassword = "D0ntCh8ngeTh1s"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = True
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fileout= fs.OpenTextFile(strlogfile ,8,True)
If fs.fileexists(strUserFileN ame) Then
Set filein = fs.OpenTextFile(strUserFil eName, 1)
Else
fileout.writeline:fileout. writeline( "!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!")
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem opening the New_users file. Make sure the " & strUserFileName & " file exists!")
fileout.writeline
fileout.writeline("!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!")
WScript.Quit
End If
fileout.writeline:fileout. writeline( "********* ********** ********** ********** ********** ********** ********** ********** ******")
fileout.writeline("Beginni ng creation of new users and mailboxes on " & Now)
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil eName, 1, -1)
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 1 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), ",", -1, 1)
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
Wscript.echo strGivenName
strSurname = arrCurrUserInfo(2)
Wscript.echo strSurname
strAlias = arrCurrUserInfo(0)
Wscript.echo strAlias
strCompany = arrCurrUserInfo(3)
Wscript.echo strCompany
strDepartment = arrCurrUserInfo(4)
Wscript.echo strDepartment
strTelephone = arrCurrUserInfo(5)
Wscript.echo strTelephone
strExchServerName = arrCurrUserInfo(6)
Wscript.echo strExchServerName
strStorageGroup = arrCurrUserInfo(7)
Wscript.echo strStorageGroup
strMailboxStore = arrCurrUserInfo(8)
Wscript.echo strMailboxStore
strTrustedDomain = arrCurrUserInfo(9)
Wscript.echo strTrustedDomain
strEmail = arrCurrUserInfo(10)
Wscript.echo strEmail
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE" )
strDomainDN = iAdRootDSE.Get("defaultNam ingContext ")
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha ngeServer" )
Set objSG = CreateObject("CDOEXM.Stora geGroup")
Set objMSDB = CreateObject("CDOEXM.Mailb oxStoreDB" )
Set iDS = objServer.GetInterface("ID ataSource" )
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName) = False Or ValidateName(strSurname) = False Then
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ########################## ########## ########## ########## ########## ########## ######
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs er, strLDAPUrl)
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval )
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval )
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
fileout.writeline("******* ********** ********** ********** ********** ********** ********** ********** ********")
MsgBox("Done")
' Exit the application.
wscript.Quit
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUserMailbox(objUs er, strLDAPUrl)
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl" , 2
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm lhttp")
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
Can you add the first line with the below?
Alias,First Name,Last Name,CompanyName,Departmen t,Telephon e number,Exchange Server,First Storage Group,Mailbox Store,Domain Name,email address
Second line should be your inputs
regards
Chandru
Here is the final code.............
1) Create a new AD User
2) Create a mailbox for this user
3) Create the physical mailbox on the Exchange server (optional, not necessary for this script to work)
'Create script
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
strUserFileName = "NewUsers.csv"
strPassword = "D0ntCh8ngeTh1s"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = True
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi
Set fileout= fs.OpenTextFile(strlogfile
If fs.fileexists(strUserFileN
Set filein = fs.OpenTextFile(strUserFil
Else
fileout.writeline:fileout.
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem
fileout.writeline
fileout.writeline("!!!!!!!
WScript.Quit
End If
fileout.writeline:fileout.
fileout.writeline("Beginni
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 1 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
Wscript.echo strGivenName
strSurname = arrCurrUserInfo(2)
Wscript.echo strSurname
strAlias = arrCurrUserInfo(0)
Wscript.echo strAlias
strCompany = arrCurrUserInfo(3)
Wscript.echo strCompany
strDepartment = arrCurrUserInfo(4)
Wscript.echo strDepartment
strTelephone = arrCurrUserInfo(5)
Wscript.echo strTelephone
strExchServerName = arrCurrUserInfo(6)
Wscript.echo strExchServerName
strStorageGroup = arrCurrUserInfo(7)
Wscript.echo strStorageGroup
strMailboxStore = arrCurrUserInfo(8)
Wscript.echo strMailboxStore
strTrustedDomain = arrCurrUserInfo(9)
Wscript.echo strTrustedDomain
strEmail = arrCurrUserInfo(10)
Wscript.echo strEmail
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE"
strDomainDN = iAdRootDSE.Get("defaultNam
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha
Set objSG = CreateObject("CDOEXM.Stora
Set objMSDB = CreateObject("CDOEXM.Mailb
Set iDS = objServer.GetInterface("ID
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName)
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ##########################
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ##########################
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ##########################
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio
fileout.writeline("*******
MsgBox("Done")
' Exit the application.
wscript.Quit
'/////////////////////////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'/////////////////////////
Function CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'/////////////////////////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'/////////////////////////
Function CreateNewUserMailbox(objUs
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl"
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'/////////////////////////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'/////////////////////////
Function CreateMailboxFolders(strEx
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'/////////////////////////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'/////////////////////////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'/////////////////////////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
Can you add the first line with the below?
Alias,First Name,Last Name,CompanyName,Departmen
Second line should be your inputs
regards
Chandru
ASKER
Hi chandru thanks a lot to take time...
I get this in the log...
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/6/2007 10:39:56 PM
The input line for user n° 2 has an incorrect syntax
The input line for user n° 3 has an incorrect syntax
Creation of users and mailboxes ended on 10/6/2007 10:40:00 PM: 3 users processed.
************************** ********** ********** ********** ********** ********** *********
In the csv file as you mentioned i have mentioned the headers and below it the content should i use "," Comma or the symbol which ROb mentioned "§"
I get this in the log...
**************************
Beginning creation of new users and mailboxes on 10/6/2007 10:39:56 PM
The input line for user n° 2 has an incorrect syntax
The input line for user n° 3 has an incorrect syntax
Creation of users and mailboxes ended on 10/6/2007 10:40:00 PM: 3 users processed.
**************************
In the csv file as you mentioned i have mentioned the headers and below it the content should i use "," Comma or the symbol which ROb mentioned "§"
Whoops! Sorry forgot to tell you that i have changed it to ","
Can you give it a try?
Can you give it a try?
Can you poste the CSV file you are using?
ASKER
Chandru tried changing it to "," still same message in the log file.
Here is the csv file...
Alias,First Name,Last Name,CompanyName,Departmen t,Telephon e number,Exchange Server,First Storage Group,Mailbox Store,Domain Name,email address
Rameshm,Ramesh,Mahesh,clar a,IT,23462 4564,excha nge1,Secon d Storage Group,Services,Development ,Ramesh.ma hesh@plc.c om
Here is the csv file...
Alias,First Name,Last Name,CompanyName,Departmen
Rameshm,Ramesh,Mahesh,clar
Can u try changing the line
For iLineNum = 1 To UBound(arrNewUsersInfo)
to
For iLineNum = 0 To UBound(arrNewUsersInfo)
Can you make sure that no space after the first line of input?
Delete the first line "Alias,First Name,Last Name,CompanyName,Departmen t,Telephon e number,Exchange Server,First Storage Group,Mailbox Store,Domain Name,email address"
For iLineNum = 1 To UBound(arrNewUsersInfo)
to
For iLineNum = 0 To UBound(arrNewUsersInfo)
Can you make sure that no space after the first line of input?
Delete the first line "Alias,First Name,Last Name,CompanyName,Departmen
ASKER
When i run the script i get all popups to click "ok" for each and every option and later no "Done" button come. The process Wscript.exe going on and on...
In the log i get user created and mailbox created.
I just checked ADS and i could see the use but in disabled state...Exchnage mailbos is also created fine.
1. Just need to work on the popups
2. Why is the process not finishing
3. getting the user as disabled.
In the log i get user created and mailbox created.
I just checked ADS and i could see the use but in disabled state...Exchnage mailbos is also created fine.
1. Just need to work on the popups
2. Why is the process not finishing
3. getting the user as disabled.
Try deleting these lines or comment these lines...............
'Wscript.echo strGivenName
'Wscript.echo strSurname
'Wscript.echo strAlias
'Wscript.echo strCompany
'Wscript.echo strDepartment
'Wscript.echo strTelephone
'Wscript.echo strExchServerName
'Wscript.echo strStorageGroup
'Wscript.echo strMailboxStore
'Wscript.echo strTrustedDomain
'Wscript.echo strEmail
'WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
'WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
To enable the account
Can you please uncomment the line?
objUser.AccountDisabled = False
'Wscript.echo strGivenName
'Wscript.echo strSurname
'Wscript.echo strAlias
'Wscript.echo strCompany
'Wscript.echo strDepartment
'Wscript.echo strTelephone
'Wscript.echo strExchServerName
'Wscript.echo strStorageGroup
'Wscript.echo strMailboxStore
'Wscript.echo strTrustedDomain
'Wscript.echo strEmail
'WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
'WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
To enable the account
Can you please uncomment the line?
objUser.AccountDisabled = False
Can u post the results?
Can you try changing this line?
MsgBox("Done")
to
Wscript.echo "Done"
Can you also see whether you are able to see find wscript.exe in the taskmanager?
MsgBox("Done")
to
Wscript.echo "Done"
Can you also see whether you are able to see find wscript.exe in the taskmanager?
ASKER
Ya now the popup's dont come and the account creates enabled.
Next
1. In the created users propertied in account > User logon name next to it is a drop down where i have domain names displayed i want the first 1 to be select while creating.
2. What is the first colum in the csv (Alias) can you remove it.
3. Next can we add in Title,Office,Description,W ebsite,Mob ile no,Phone no,Managername,Adding to groups all sort as the next step in finishing the whole package.
It is still taking a long time to finish for a single user.
As you have mentioned
3) Create the physical mailbox on the Exchange server (optional, not necessary for this script to work)
I think this is taking the time and failing.
Next
1. In the created users propertied in account > User logon name next to it is a drop down where i have domain names displayed i want the first 1 to be select while creating.
2. What is the first colum in the csv (Alias) can you remove it.
3. Next can we add in Title,Office,Description,W
It is still taking a long time to finish for a single user.
As you have mentioned
3) Create the physical mailbox on the Exchange server (optional, not necessary for this script to work)
I think this is taking the time and failing.
ASKER
after 15 min i get the done box.
Here is the data from the log...
************************** ********** ********** ********** ********** ********** *********
Beginning creation of new users and mailboxes on 10/7/2007 12:52:01 AM
Beginning creation of Ramesh Mahesh
... Succesfully created user.
... Succesfully created mailbox.
... Failed to create the mailbox folders for Ramesh Mahesh before logon.
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/7/2007 1:02:17 AM: 2 users processed.
************************** ********** ********** ********** ********** ********** *********
Here is the data from the log...
**************************
Beginning creation of new users and mailboxes on 10/7/2007 12:52:01 AM
Beginning creation of Ramesh Mahesh
... Succesfully created user.
... Succesfully created mailbox.
... Failed to create the mailbox folders for Ramesh Mahesh before logon.
The input line for user n° 2 has an incorrect syntax
Creation of users and mailboxes ended on 10/7/2007 1:02:17 AM: 2 users processed.
**************************
Can you let me know where exchange server is located? If it is located locally it will not take time.
ASKER
Its in the same machine where i am running the script.
Did you check on the error in the log...
Did you check on the error in the log...
Are you in office?
What version of exchange server?
What version of exchange server?
ASKER
No at home but can connect.
Its Exchange 2003.
Its Exchange 2003.
Can you change this part of the script as this is taking time to because of looping 120 times.
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
to
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 60000
NumofTry = 10
iCounter = 0
Try this.........
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
to
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 60000
NumofTry = 10
iCounter = 0
Try this.........
ASKER
Is the delay not because of this.
... Failed to create the mailbox folders for Ramesh Mahesh before logon.
As when i open the file in 2 min except this the success lines are created.
Fater 15 min only the ablove lines comes to the log.
I just checked after the chages but still take a long time.
... Failed to create the mailbox folders for Ramesh Mahesh before logon.
As when i open the file in 2 min except this the success lines are created.
Fater 15 min only the ablove lines comes to the log.
I just checked after the chages but still take a long time.
Let me try the same in my setup with all the changes and get back to you tomorrow
My Exchange server is not in Chennai so i didn't get a chance to test this. I have a test setup where i can try.
My Exchange server is not in Chennai so i didn't get a chance to test this. I have a test setup where i can try.
ASKER
Ok Chandru...Thanks...
You can see that the final code that i posted did not take this much of time.
You can see that the final code that i posted did not take this much of time.
But the previous code doesn't have the create mailbox folders enabled. I think that would be the reason
ASKER
But the mailbox was also created with the code.It took a while to replicate but i could see the mailbox in ESM.
Can you post the code once again?
ASKER
Here is the code.......
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fileout= fs.OpenTextFile(strlogfile ,8,True)
If fs.fileexists(strUserFileN ame) Then
Set filein = fs.OpenTextFile(strUserFil eName, 1)
Else
fileout.writeline:fileout. writeline( "!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!")
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem opening the New_users file. Make sure the " & strUserFileName & " file exists!")
fileout.writeline
fileout.writeline("!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!")
WScript.Quit
End If
fileout.writeline:fileout. writeline( "********* ********** ********** ********** ********** ********** ********** ********** ******")
fileout.writeline("Beginni ng creation of new users and mailboxes on " & Now)
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil eName, 1, -1)
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), "§", -1, 1)
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE" )
strDomainDN = iAdRootDSE.Get("defaultNam ingContext ")
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha ngeServer" )
Set objSG = CreateObject("CDOEXM.Stora geGroup")
Set objMSDB = CreateObject("CDOEXM.Mailb oxStoreDB" )
Set iDS = objServer.GetInterface("ID ataSource" )
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName) = False Or ValidateName(strSurname) = False Then
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ########################## ########## ########## ########## ########## ########## ######
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs er, strLDAPUrl)
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval )
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval )
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName & " " & strGivenName & " " & strAlias)
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
fileout.writeline("******* ********** ********** ********** ********** ********** ********** ********** ********")
MsgBox("Done")
' Exit the application.
wscript.Quit
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUserMailbox(objUs er, strLDAPUrl)
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl" , 2
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm lhttp")
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr iptor")
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H 20014,0,0, 1,0,0 '&H20014 -> gives Read permissions
AddAce dacl,strExternalAccount,&H 100,5,0,1, "{AB721A54 -1E2F-11D0 -9819-00AA 0040529B}" ,0 '&H100 & the string -> enables the Send As permissions
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr ay(oSecuri tyDescript or)
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre tionaryAcl
Set ace = CreateObject("AccessContro lEntry")
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13 1079,0,2,0 ,0,0
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre tionaryAcl = dacl
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro lEntry")
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType) <> "0" Then
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = False
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi
Set fileout= fs.OpenTextFile(strlogfile
If fs.fileexists(strUserFileN
Set filein = fs.OpenTextFile(strUserFil
Else
fileout.writeline:fileout.
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem
fileout.writeline
fileout.writeline("!!!!!!!
WScript.Quit
End If
fileout.writeline:fileout.
fileout.writeline("Beginni
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
strSurname = arrCurrUserInfo(2)
strAlias = arrCurrUserInfo(0)
strCompany = arrCurrUserInfo(3)
strDepartment = arrCurrUserInfo(4)
strTelephone = arrCurrUserInfo(5)
strExchServerName = arrCurrUserInfo(6)
strStorageGroup = arrCurrUserInfo(7)
strMailboxStore = arrCurrUserInfo(8)
strTrustedDomain = arrCurrUserInfo(9)
strEmail = arrCurrUserInfo(10)
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE"
strDomainDN = iAdRootDSE.Get("defaultNam
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha
Set objSG = CreateObject("CDOEXM.Stora
Set objMSDB = CreateObject("CDOEXM.Mailb
Set iDS = objServer.GetInterface("ID
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName)
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ##########################
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ##########################
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ##########################
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
' ##########################
' If the mailbox was created, then attempt to change the ACL on the User objecct
If bContinue Then
bContinue = Add_ACE_ADUser(strSurName & " " & strGivenName & " " & strAlias)
End If
' ##########################
' If the User object ACL list was changed, then attempt to change
' the ACL on the Mailbox objecct
If bContinue Then
bContinue = Add_ACE_Mailbox(strSurName
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio
fileout.writeline("*******
MsgBox("Done")
' Exit the application.
wscript.Quit
'/////////////////////////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'/////////////////////////
Function CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
'objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'/////////////////////////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'/////////////////////////
Function CreateNewUserMailbox(objUs
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl"
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'/////////////////////////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'/////////////////////////
Function CreateMailboxFolders(strEx
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'/////////////////////////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'/////////////////////////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'/////////////////////////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
'/////////////////////////
'// Function: Add Read & Send As permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read & Send As permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_ADUser(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Add_ACE_ADUser = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
Set oSecurityDescriptor = oUser.Get("ntSecurityDescr
Err.Clear
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
AddAce dacl,strExternalAccount,&H
AddAce dacl,strExternalAccount,&H
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.Put "ntSecurityDescriptor",Arr
' Commit changes from the property cache to the information store.
oUser.SetInfo
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read' & 'Send As' permissions to the account: " & Err.Description & "(" & Err.Number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
fileout.writeline "... Succesfully added the 'Read' & 'Send As' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = nothing
End Function
'/////////////////////////
'// Function: Adds Read, Full mailbox access & Associate Extenal Account
'// permissions to the new User object
'//
'// Purpose: This code will add a (trusted) external user account to the ACE
'// list with Read, Full mailbox access & Associate Extenal Account
'// permission
'//
'// Input: strUser = the User object that needs to have its ACL changed
'//
'// Returns: True if the ACE addition was succesful.
'/////////////////////////
Function Add_ACE_Mailbox(strADUser)
On Error Resume Next
Dim oUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim btemp
Add_ACE_Mailbox = False
Set oUser = GetObject ("LDAP://cn=" & strADUser & "," & strOU & "," & strDomainDN)
' Get the Mailbox security descriptor (SD).
Set oSecurityDescriptor = oUser.MailboxRights
' Extract the Discretionary Access Control List (DACL) using the IADsSecurityDescriptor.
' Interface.
Set dacl = oSecurityDescriptor.Discre
Set ace = CreateObject("AccessContro
'Since you can't add the Associated External Account if another user already got it
bTemp=1
For Each ace In dacl
' Display all the properties of the ACEs using the IADsAccessControlEntry interface.
' WScript.Echo ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
If (ace.AccessMask And 131079) = 131079 Then
bTemp=0
Exit For
End If
Next
' Template: AddAce(TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
if bTemp=1 Then
AddAce dacl,strExternalAccount,13
' Add the modified DACL to the security descriptor.
oSecurityDescriptor.Discre
' Save new SD onto the user.
oUser.MailboxRights = oSecurityDescriptor
' Commit changes from the property cache to the information store.
oUser.SetInfo
'objlogfile.writeline obname & "," & strFound & "," & Now & ",Modified"
Else
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account:"
fileout.writeline "... These permlissions are already defined on another account."
End If
If Err.Number <> 0 Then
fileout.writeline "... Failed to give the 'Read', 'Full Mailbox Access' & 'Associate External Account' permissions to the account: " & Err.Description & "(" & Err.number & ")."
If Err.Number = -2147023559 Then fileout.writeline "... The External account " & strExternalAccount & " probably doesn't exist."
Add_ACE_ADUser = False
Exit Function
End If
Add_ACE_ADUser = True
if bTemp=1 Then fileout.writeline "... Succesfully added the 'Read', 'Full Mailbox' & 'Associate External Account' permissions to the account."
'Clean up
Set oUser = nothing
Set oSecurityDescriptor = Nothing
End Function
'/////////////////////////
'// Function: Changes the ACL of an object
'//
'// Purpose: This code actually changes the ACL list of the object.
'//
'// Input: dacl = The domain controller on which the user
'// object will be created.
'//
'// TrusteeName = The (external) account to give permissions to.
'//
'// gAccessMask = The access mask value
'//
'// gAceType = The acetype flag value
'//
'// gAceFlags = The aceflags flag value
'//
'// gFlags = The flags flag value
'//
'// gObjectType = The objecttype value
'//
'// gInheritedObjectType = The inherited value
'//
'// Returns: The ACL Object.
'/////////////////////////
Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
Dim Ace1
' Create a new ACE object.
Set Ace1 = CreateObject("AccessContro
Ace1.AccessMask = gAccessMask
Ace1.AceType = gAceType
Ace1.AceFlags = gAceFlags
Ace1.Flags = gFlags
Ace1.Trustee = TrusteeName
'See whether ObjectType must be set
If CStr(gObjectType) <> "0" Then
Ace1.ObjectType = gObjectType
End If
'See whether InheritedObjectType must be set.
If CStr(gInheritedObjectType)
Ace1.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce Ace1
' Clean up
Set Ace1 = Nothing
End Function
ASKER
Hi Rob Hope you had a great weekend.
Here is the final code that chandru had edited to reduce the size...
Able to create a user and mailbox with a comma delimiter.
Need to expand this a bit.
'Create script
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri es"
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox es.txt"
strFolderLang = "en-us"
CreateMailboxFolder = True
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi leSystemOb ject")
Set fileout= fs.OpenTextFile(strlogfile ,8,True)
If fs.fileexists(strUserFileN ame) Then
Set filein = fs.OpenTextFile(strUserFil eName, 1)
Else
fileout.writeline:fileout. writeline( "!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!")
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem opening the New_users file. Make sure the " & strUserFileName & " file exists!")
fileout.writeline
fileout.writeline("!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!!!!")
WScript.Quit
End If
fileout.writeline:fileout. writeline( "********* ********** ********** ********** ********** ********** ********** ********** ******")
fileout.writeline("Beginni ng creation of new users and mailboxes on " & Now)
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil eName, 1, -1)
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin eNum), ",", -1, 1)
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
'Wscript.echo strGivenName
strSurname = arrCurrUserInfo(2)
'Wscript.echo strSurname
strAlias = arrCurrUserInfo(0)
'Wscript.echo strAlias
strCompany = arrCurrUserInfo(3)
'Wscript.echo strCompany
strDepartment = arrCurrUserInfo(4)
'Wscript.echo strDepartment
strTelephone = arrCurrUserInfo(5)
'Wscript.echo strTelephone
strExchServerName = arrCurrUserInfo(6)
'Wscript.echo strExchServerName
strStorageGroup = arrCurrUserInfo(7)
'Wscript.echo strStorageGroup
strMailboxStore = arrCurrUserInfo(8)
'Wscript.echo strMailboxStore
strTrustedDomain = arrCurrUserInfo(9)
'Wscript.echo strTrustedDomain
strEmail = arrCurrUserInfo(10)
'Wscript.echo strEmail
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE" )
strDomainDN = iAdRootDSE.Get("defaultNam ingContext ")
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha ngeServer" )
Set objSG = CreateObject("CDOEXM.Stora geGroup")
Set objMSDB = CreateObject("CDOEXM.Mailb oxStoreDB" )
Set iDS = objServer.GetInterface("ID ataSource" )
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
'WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName) = False Or ValidateName(strSurname) = False Then
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ########################## ########## ########## ########## ########## ########## ######
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs er, strLDAPUrl)
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval )
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ########################## ########## ########## ########## ########## ########## ######
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 60000
NumofTry = 10
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval )
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio n of users and mailboxes ended on " & Now & ": " & iLineNum & " users processed.")
fileout.writeline("******* ********** ********** ********** ********** ********** ********** ********** ********")
MsgBox("Done")
' Exit the application.
wscript.Quit
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUser(strDCServerN ame, strGivenName, strSurname, strAlias, _
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
' WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User" , strRecip)
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateNewUserMailbox(objUs er, strLDAPUrl)
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl" , 2
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function CreateMailboxFolders(strEx chServerNa me, strDomainDN, strAlias, _
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm lhttp")
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'///////////////////////// ////////// ////////// ////////// ////////// ////////// ///////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'///////////////////////// ////////// ////////// ////////// ////////// ////////// //////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
Need to expand this.
The csv file should have a header.
need to add groups
need to add address,mobileno,office,ti tle,design ation etc.
Here is the final code that chandru had edited to reduce the size...
Able to create a user and mailbox with a comma delimiter.
Need to expand this a bit.
'Create script
Option Explicit
'On Error Resume Next
On Error GoTo 0
' Declare variables for input parameters.
Dim strDCServerName ' As String
Dim strExchServerName ' As String
Dim strStorageGroup ' As String
Dim strMailboxStore ' As String
Dim strUserFileName ' As String
Dim strGivenName ' As String
Dim strSurname ' As String
Dim strAlias ' As String
Dim strPassword ' As String
Dim strCompany ' As String
Dim strDepartment ' As String
Dim strTelephone ' As String
Dim stremail ' As String
Dim bIsFound ' As Boolean
Dim i ' As Integer
Dim vProxyAddresses ' As Array
Dim nProxyAddresses ' As Array
Dim strFolderLang ' As String
Dim strExternalAccount ' As String
Dim strTrustedDomain ' As String
Dim strLogFile ' As String
' Declare variables used for verifying the existance of the mailbox store
' where the mailbox is to be created.
Dim iDS ' As IDataSource
Dim iAdRootDSE ' As ActiveDs.IADs
Dim objServer ' CDOEXM.ExchangeServer
Dim objSG ' CDOEXM.StorageGroup
Dim objMSDB ' CDOEXM.MailboxStoreDB
Dim storegroup ' CDOEXM.MailboxStoreDB
Dim mbx ' CDOEXM.MailboxStoreDB
Dim bFound ' As Boolean
Dim CreateMailboxFolder ' As Boolean
' Declare variables for iterating through the
' file of new users.
Dim objUser ' As IADsUser
Dim strDomainDN ' As String
Dim strLDAPUrl ' As String
Dim strOU ' As String
Dim arrNewUsersInfo ' As Array
Dim strCurrUserInfo ' As String
Dim arrCurrUserInfo ' As Array
Dim fs ' As FileSystemObject
Dim filein ' As As fs.TextStream
Dim fileout ' As As fs.TextStream
Dim tsNewUsers ' As FSO.TextStream
Dim iLineNum ' As Integer
Dim bContinue ' As Boolean
Dim TimeInterval ' As Integer
Dim NumofTry ' As Integer
Dim iCounter ' As Integer
' Get input parameters.
strDCServerName = "indc01"
strOU = "OU=Named Accounts,OU=User Accounts,OU=IND,OU=Countri
strUserFileName = "NewUsers.csv"
strPassword = "abc123"
strLogFile = "Created_Users_and_Mailbox
strFolderLang = "en-us"
CreateMailboxFolder = True
'Open the New_users filename to read in all contacts
Err.Clear
Set fs = CreateObject("Scripting.Fi
Set fileout= fs.OpenTextFile(strlogfile
If fs.fileexists(strUserFileN
Set filein = fs.OpenTextFile(strUserFil
Else
fileout.writeline:fileout.
fileout.writeline
fileout.writeline("Error reported on " & Now)
fileout.writeline("Problem
fileout.writeline
fileout.writeline("!!!!!!!
WScript.Quit
End If
fileout.writeline:fileout.
fileout.writeline("Beginni
fileout.writeline
' Open the new users file.
Set tsNewUsers = fs.OpenTextFile(strUserFil
' Error handling.
If Err <> 0 Then
fileout.writeline "An error occurred opening the file of new users."
fileout.writeline "Error: " & Err.Number & " " & Err.Description
fileout.writeline "Exiting the application."
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
wscript.Quit
End If
' Get all lines from the new users file and split
' them into an array of strings.
arrNewUsersInfo = Split(tsNewUsers.ReadAll, vbCrLF)'Chr(13))
' Iterate through the array of new users.
For iLineNum = 0 To UBound(arrNewUsersInfo)
wscript.sleep(1000)
Err.Clear
bContinue = True
' Split the given name, surname, alias, and
' password strings into the array.
arrCurrUserInfo = Split(arrNewUsersInfo(iLin
' Check the number of elements in the array.
If UBound(arrCurrUserInfo) = 10 Then
' Get the given name, surname, e-mail alias, and password from the array.
strGivenName = arrCurrUserInfo(1)
'Wscript.echo strGivenName
strSurname = arrCurrUserInfo(2)
'Wscript.echo strSurname
strAlias = arrCurrUserInfo(0)
'Wscript.echo strAlias
strCompany = arrCurrUserInfo(3)
'Wscript.echo strCompany
strDepartment = arrCurrUserInfo(4)
'Wscript.echo strDepartment
strTelephone = arrCurrUserInfo(5)
'Wscript.echo strTelephone
strExchServerName = arrCurrUserInfo(6)
'Wscript.echo strExchServerName
strStorageGroup = arrCurrUserInfo(7)
'Wscript.echo strStorageGroup
strMailboxStore = arrCurrUserInfo(8)
'Wscript.echo strMailboxStore
strTrustedDomain = arrCurrUserInfo(9)
'Wscript.echo strTrustedDomain
strEmail = arrCurrUserInfo(10)
'Wscript.echo strEmail
'strPassword = arrCurrUserInfo(11)
strExternalAccount = strTrustedDomain & "\" & strAlias
fileout.writeline "Beginning creation of " & strGivenName & " " & strSurname
' Verify that the specified mailbox store exists.
' Initialize bFound.
bFound = False
' Get the default naming context.
Set iAdRootDSE = GetObject("LDAP://RootDSE"
strDomainDN = iAdRootDSE.Get("defaultNam
' Create objects for verifying existance of
' the mailbox store where the mailbox will be created.
Set objServer = CreateObject("CDOEXM.Excha
Set objSG = CreateObject("CDOEXM.Stora
Set objMSDB = CreateObject("CDOEXM.Mailb
Set iDS = objServer.GetInterface("ID
' Bind to the Exchange server.
iDS.Open strExchServerName
' Check that the destination mailbox store exists.
For Each storegroup In objServer.StorageGroups
'WScript.Echo "Attempting to open Storaget Group: " & storegroup & " on server: " & strExchServerName
objSG.DataSource.Open storegroup
' Error handling. If CDOEXM attempts to open a Recovery
' Storage Group, a 0xC1032221 error will be returned.
If Err.Number <> 0 Then
fileout.writeline "An error occurred opening the specified storage group."
fileout.writeline "Error: 0x" & Hex(Err.Number) & " " & Err.Description
' Clean up.
Set objSG = Nothing
Exit For
End If
If UCase(strStorageGroup) = UCase(objSG.Name) Then
For Each mbx In objSG.MailboxStoreDBs
objMSDB.DataSource.Open mbx
If UCase(strMailboxStore) = UCase(objMSDB.Name) Then
bFound = True
' Get the LDAP URL for the mailbox store.
strLDAPUrl = "LDAP://" + mbx
Exit For
End If
Next
End If
If bFound Then Exit For
Next
' Clean up.
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
' If the mailbox store was not found, exit the program.
If bFound = False Then
fileout.writeline "The specified mailbox store could not be found."
End If
' Validate the given and surnames.
If ValidateName(strGivenName)
bContinue = False
End If
' Validate the e-mail alias.
If ValidateAlias(strAlias) = False Then
bContinue = False
End If
Else
fileout.writeline "The input line for user n° " & iLineNum + 1 & " has an incorrect syntax"
bContinue = False
End If
' ##########################
' If input validation passed, then attempt to create the user object.
If bContinue Then
bContinue = CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
End If
' ##########################
' If the user object was successfully created, then attempt to create the mailbox.
' wait 1 second before creating the mailbox
wscript.sleep(1000)
If bContinue Then
' Initialize the variables.
TimeInterval = 5000
NumofTry = 120
iCounter = 0
' Depending on the size of the network, the Recipient Update
' Service may take some time to propagate the new user
' to the Exchange server. Attempt to create the mailbox every
' 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Attempt to create the mailbox in the specified
' mailbox store.
bContinue = CreateNewUserMailbox(objUs
' Continue if CreateNewUserMailbox succeeded.
If bContinue Then Exit Do
iCounter = iCounter + 1
' Wait before trying again.
wscript.sleep(TimeInterval
Loop
' Could not create the mailbox after NumofTry attempts.
If iCounter >= NumofTry Then
bContinue = False
End If
End If
' ##########################
' If the mailbox was created, then attempt to force the Exchange server to create the mailbox folders.
' First check if the mailbox folder needs to be created, because it can take a while
' for each account because of replication latency
If CreateMailboxFolder = True then
If bContinue Then
' Initialize the variables.
TimeInterval = 60000
NumofTry = 10
iCounter = 0
' Directory Service replication may take some time. Attempt
' to force the Exchange server to create the mailbox folders
' every 5 seconds for 10 minutes.
Do While iCounter < NumofTry
' Wait for a certain time interval before trying again.
wscript.sleep(TimeInterval
' Attempt to force the Exchange server to create the
' mailbox folders in the specified language..
If CreateMailboxFolders(strEx
strPassword, strFolderLang) Then Exit Do
iCounter = iCounter + 1
Loop
' Could not create the mailbox folders after NumofTry attempts.
If iCounter >= NumofTry Then
fileout.writeline "... Failed to create the mailbox folders for " & strGivenName & " " & strSurname & " before logon."
End If
End If
End If
fileout.writeline("")
Next
' Close the file.
tsNewUsers.Close
' Clean up.
Set fs = Nothing
Set tsNewUsers = Nothing
fileout.writeline
fileout.writeline("Creatio
fileout.writeline("*******
MsgBox("Done")
' Exit the application.
wscript.Quit
'/////////////////////////
'// Function: CreateNewUser
'//
'// Purpose: Creates a new user in Active Directory with the specified given name,
'// surname, e-mail alias, and password.
'//
'//
'// Input: strDCServerName = The domain controller on which the user
'// object will be created.
'//
'// strGivenName = The given name of the new user.
'//
'// strSurname = The surname of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strCompany = The company for the new user.
'//
'// strDepartment = The department for the new user.
'//
'// strTelephone = The telephone for the new user.
'//
'// Output: objUser = The user object for the new user.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// Returns: True if AD user object is created, False if it isn't.
'/////////////////////////
Function CreateNewUser(strDCServerN
strPassword, strCompany, strDepartment, strTelephone, objUser, strDomainDN)
On Error Resume Next
On Error GoTo 0
CreateNewUser = False
' Declare program variables.
Dim objContainer 'As IADsContainer
Dim strRecip 'As String
' Build the recipient string.
strRecip = "CN=" & strSurName & " " & strGivenName & " " & strAlias
'Get the container.
' WScript.Echo "Attempting to connect to: " & "LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN
Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Get the container.
'Set objContainer = GetObject("LDAP://" & strDCServerName & "/" & strOU & "," & strDomainDN)
' Initialize the user object.
Set objUser = objContainer.Create("User"
' Set the display name, account name, given name, surname, an
' and userprinciple properties of the user object.
objUser.Put "displayname", strSurname & ", " & strGivenName
objUser.Put "sAMAccountName", strAlias
objUser.Put "givenName", strGivenName
objUser.Put "sn", strSurname
objUser.Put "company", strCompany
objUser.Put "department", strDepartment
objUser.Put "telephoneNumber", strTelephone
objUser.Put "userPrincipalName", strAlias
objUser.Put "mail", strEmail
' Save the changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating user object"
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
If Err.Number = -2147019886 Then
fileout.writeline "... The object already exists."
CreateNewUser = False
Exit Function
End If
CreateNewUser = False
Exit Function
End If
' Set the password for the new user. This should be changed by the user
' after he or she logs on.
objUser.SetPassword strPassword
' Enable the new user account.
objUser.AccountDisabled = False
' Clean up.
Set objContainer = Nothing
Set objServer = Nothing
Set objSG = Nothing
Set objMSDB = Nothing
fileout.writeline "... Succesfully created user."
CreateNewUser = True
End Function
'/////////////////////////
'// Function: CreateNewUserMailbox
'//
'// Purpose: Creates a mailbox for the new user in the specified
'// mailbox store.
'//
'//
'// Input: objUser = The user object for the new user.
'//
'// strLDAPUrl = The LDAP URL for the new user.
'//
'// Returns: True if the mailbox is created, False if it isn't.
'/////////////////////////
Function CreateNewUserMailbox(objUs
On Error Resume Next
CreateNewUserMailbox = False
' Variables
Dim objMailbox 'As CDOEXM.IMailboxStore
' Get the IMailboxStore interface.
Set objMailbox = objUser
' Create a mailbox for the recipient on the specified Exchange server.
objMailbox.CreateMailbox strLDAPUrl
'Enable immediate-logon for the user.
objUser.Put "msExchUserAccountControl"
' Save changes to the user object.
objUser.SetInfo
' Error handling.
If Err.Number <> 0 Then
fileout.writeline "... Error creating mailbox."
fileout.writeline "... Error: " & Err.Number & " " & Err.Description
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
CreateNewUserMailbox = False
Exit Function
End If
' Clean up.
Set objUser = Nothing
Set objMailbox = Nothing
fileout.writeline "... Succesfully created mailbox."
CreateNewUserMailbox = True
End Function
'/////////////////////////
'// Function: CreateMailboxFolders
'//
'// Purpose: Forces the specified Exchange server to create the user's mailbox
'// folders if they don't already exist.
'//
'// Input: strExchServerName = The Exchange server on which the mailbox
'// has been created.
'//
'// strDomainDN = The domain DN of the new user.
'//
'// strAlias = The e-mail alias of the new user.
'//
'// strPassword = The password for the new user.
'//
'// strFolderLang = The language in which the mailbox
'// folders will be created.
'//
'/////////////////////////
Function CreateMailboxFolders(strEx
strPassword, strFolderLang)
On Error Resume Next
CreateMailboxFolders = False
' Variables
Dim strMailboxURL 'As String
Dim strUserDomain 'As String
' Build the URL to the user's mailbox.
strMailboxURL = "http://" & strExchServerName & "/Exchange/" & strAlias & "/"
' Build the Domain\Username string.
strUserDomain = Left(strDomainDN, InStr(1, strDomainDN, ",", vbTextCompare) - 1)
strUserDomain = Right(strUserDomain, Len(strUserDomain) - 3) + "\" + strAlias
' Create the XMLHTTP object.
Dim oXMLHTTP
Set oXMLHTTP = CreateObject("microsoft.xm
' Open the request object with the GET method. Specify the source URI,
' that it will run asynchronously, and the username/password of the
' new user.
oXMLHTTP.Open "GET", strMailboxURL, False, strUserDomain, strPassword
' Set the language in which the mailbox folders will be created.
oXMLHTTP.setRequestHeader "Accept-Language", strFolderLang
oXMLHTTP.setRequestHeader "Connection", "Keep-Alive"
' Send the GET method request. If the mailbox folders
' have not yet been created, this method will have the side
' effect of forcing the Exchange server to create them in
' the language specified in the "Accept-Language" header.
oXMLHTTP.Send ("")
If oXMLHTTP.Status >= 200 And oXMLHTTP.Status < 300 Then
fileout.writeline "... Mailbox folders successfully created."
CreateMailboxFolders = True
Else
'GET method did not successfully force creation of mailbox folders.
CreateMailboxFolders = False
End If
Set oXMLHTTP = Nothing
End Function
'/////////////////////////
'// Function: ValidateInput
'//
'// Purpose: Verifies that the specified server, mailbox store, or storage group name
'// is not longer than 64 characters and doesn't contain any illegal characters.
'//
'// Input: sInput = The specified server, mailbox store, or storage group name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateInput(sInput)
ValidateInput = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 64 Then
fileout.writeline "The length of the specified server, mailbox store, or storage group name" _
+ " cannot exceed 64 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ";|/|\\"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ';', '\', or '/'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateInput = True
End Function
'/////////////////////////
'// Function: ValidateAlias
'//
'// Purpose: Verifies that the specified e-mail alias is not longer than 256
'// characters, doesn't contain any illegal characters.
'//
'// Input: sInput = The specified e-mail alias.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateAlias(sInput)
ValidateAlias = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 256 Then
fileout.writeline "The length of the e-mail alias cannot exceed 256 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = ":|\*|;|<|>|\||\"""
regex.Pattern = strPattern
regex.Global = True
' Exit the application if ';', '\', or '/'
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified server, mailbox store, or storage group name cannot contain ':', '*', " & _
" '|', ';', '<', '>', or '""'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateAlias = True
End Function
'/////////////////////////
'// Function: ValidateName
'//
'// Purpose: Verifies that the specified name is not longer than 28
'// characters and doesn't contain the '<script' tag.
'//
'// Input: sInput = The specified name.
'//
'// Returns: True if the string is validated, False if it isn't.
'/////////////////////////
Function ValidateName(sInput)
ValidateName = False
Dim strPattern 'As String
Dim regex 'As RegExp
If Len(sInput) > 28 Then
fileout.writeline "The length of the name cannot exceed 28 characters."
Exit Function
End If
' Create the regular expression object.
Set regex = New RegExp
' Set the pattern to search for.
strPattern = "<script"
regex.Pattern = strPattern
regex.Global = True
' Exit the application if "<script"
' is found in the input string.
If regex.Test(sInput) Then
fileout.writeline "The specified name cannot contain '<script'."
' Clean up.
Set regex = Nothing
' Exit the application.
Exit Function
End If
' Clean up.
Set regex = Nothing
ValidateName = True
End Function
Need to expand this.
The csv file should have a header.
need to add groups
need to add address,mobileno,office,ti
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Rob user created from the csv with the headers fine. But it takes more than 5 min to create a single user with the headers.For the Done button to come it takes so long.But the log file it shows "Sucessfully created user and mailbox in say 30 sec.And when i check the Ads the user is also showing there.
If you can intergrate the other details from the old question to this it would be great
Can you help on this...
If you can intergrate the other details from the old question to this it would be great
Can you help on this...
Sharath,
I think it is taking time because of the mailbox folder creation. We can comment those line and you can test. The mailbox folder will be created automatically when the user logs in first time
regards
Chandru
I think it is taking time because of the mailbox folder creation. We can comment those line and you can test. The mailbox folder will be created automatically when the user logs in first time
regards
Chandru
ASKER
Which are the line
Try changing this line as below
CreateMailboxFolder = False
CreateMailboxFolder = False
ASKER
ya now its fast...
ASKER
Hi Rob and Chandru,
As disscussed ro i have raised a Q for get details from mails to excel...
https://www.experts-exchange.com/questions/22880459/Convert-these-mails-to-excel.html
Chandru can you also help please....
As disscussed ro i have raised a Q for get details from mails to excel...
https://www.experts-exchange.com/questions/22880459/Convert-these-mails-to-excel.html
Chandru can you also help please....
if you are happy with this we can work on the other part and when the user logs in for the first time the mailbox folders will be created
I think the post has reached more than 100 comments. Can you open a new question?
Rob - Hope you agree
Rob - Hope you agree
ASKER
Yes i am ok with it Chandru.
As mentioned by Rob the link
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Already has the working of adding many more fields to the excel.So can you and Rob help in adding them to this script...
I think there we were stuck in adding the user to a "Root domain group"
As mentioned by Rob the link
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Already has the working of adding many more fields to the excel.So can you and Rob help in adding them to this script...
I think there we were stuck in adding the user to a "Root domain group"
ASKER
Ok i can close the Q and raise a continuation Q Rob and Chandru please suggest whome the points needs to be given...:)
Thanks Sharath....
Yes we can work on getting both the script combined
Yes we can work on getting both the script combined
Offcourse Rob............
ASKER
Here is the New Q...
https://www.experts-exchange.com/questions/22880472/Create-users-from-excel-Continuation.html
Just for others information we started this from this Q....
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Next this the present Q...
https://www.experts-exchange.com/questions/22846683/Create-users-and-mailboxes-from-a-excel.html
Now the 3rd continuation Q is here
https://www.experts-exchange.com/questions/22880472/Create-users-from-excel-Continuation.html
Thanks a lot Rob and chandru for making this happen...It is a very important one for me
https://www.experts-exchange.com/questions/22880472/Create-users-from-excel-Continuation.html
Just for others information we started this from this Q....
https://www.experts-exchange.com/questions/22804838/Need-to-create-users-in-ADS-from-the-excel-file.html
Next this the present Q...
https://www.experts-exchange.com/questions/22846683/Create-users-and-mailboxes-from-a-excel.html
Now the 3rd continuation Q is here
https://www.experts-exchange.com/questions/22880472/Create-users-from-excel-Continuation.html
Thanks a lot Rob and chandru for making this happen...It is a very important one for me
Hey wow! I go away go away for a couple of hours, then things have happened, and I need to catch up! LOL!
Thanks for the points, but splitting them probably would have been better. Sharath, you can accept multiple answers to split the points between.....but it doesn't really matter anyway!
OK, I'll catch up on what's been happening....
Rob.
Thanks for the points, but splitting them probably would have been better. Sharath, you can accept multiple answers to split the points between.....but it doesn't really matter anyway!
OK, I'll catch up on what's been happening....
Rob.
ASKER
Ok Rob...The above lik will show you the new Question i have posted...
Do you want to create users and there mailboxes from Excel?
regards
Chandru