Public Sub CreateAdAccount(myRec)
Dim gname, sname, sGroupName, sPassword, FullName, Alias, MailAlias, MDBName, StorageGroup, Server, AdminGroup, Organization, DomainDN As String
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser
gname = DLookup("NewStaff_F_Name", "NewStaffRequests", "ID = " & myRec)
sname = DLookup("NewStaff_L_Name", "NewStaffRequests", "ID = " & myRec)
sGroupName = DLookup("DefaultPrinter", "NewStaffRequests", "ID = " & myRec)
If Len(DLookup("SharedFolders", "NewStaffRequests", "ID = " & myRec)) > 0 Then
sGroupName = sGroupName & "," & DLookup("SharedFolders", "NewStaffRequests", "ID = " & myRec)
End If
If Len(DLookup("Databases", "NewStaffRequests", "ID = " & myRec)) > 0 Then
sGroupName = sGroupName & "," & DLookup("Databases", "NewStaffRequests", "ID = " & myRec)
End If
If Len(DLookup("EmailGroups", "NewStaffRequests", "ID = " & myRec)) > 0 Then
sGroupName = sGroupName & "," & DLookup("EmailGroups", "NewStaffRequests", "ID = " & myRec)
End If
'clean groups
sGroupName = Replace(Groups, "NoGroup,", "")
'*****======Time Out =========******
'Check for existing AD Record
Dim MySql As String
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
MySql = "SELECT sAMAccountName FROM 'LDAP://dc=domain,dc=com' WHERE " _
& "givenName='" & gname & "' AND sn='" & sname & "'"
Set rs = CreateObject("ADODB.Recordset")
rs.Open MySql, objConnection, 1 ' 1 = adOpenKeyset
If rs.RecordCount = 1 Then
MsgBox "This User exists on the PBMHMR network. Please call 432-555-5555 for assistance."
Exit Sub
End If
objRecordset.Close
'*****====Time Out Ended=====*****
'Open modifying connection to Active Directory
Set RootDSE = GetObject("LDAP://RootDSE")
DomainContainer = RootDSE.Get("defaultNamingContext")
Set oOU = GetObject("LDAP://CN=Users;DC=domain,DC=com")
'Set variables you will need to complete task
ID = DLookup("StaffID", "NewStaffRequests", "ID = " & myRec)
sPassword = "MyP@ssw0rd"
FullName = gname & " " & sname
Alias = LCase(Left(gname, 1) & sname)
MailAlias = gname & sname
MDBName = "Mailbox Store (EXCH_CENTER)"
StorageGroup = "First Storage Group"
Server = "EXCH_CENTER"
AdminGroup = "First Administrative Group"
Organization = "NAMEhere"
DomainDN = "DC=domain,DC=com"
' Update User Record
Set oUser = oOU.Create("user", "cn=" & FullName)
oUser.Put "cn", FullName
oUser.Put "SamAccountName", FullName
oUser.Put "userPrincipalName", FullName & "@domain.com"
oUser.Put "givenName", gname
oUser.Put "sn", sname
oUser.Put "displayName", FullName
oUser.Put "mailNickname", MailAlias
oUser.Put "description", ID
oUser.Put "ScriptPath", "Slogic.bat"
oUser.Put "mDBUseDefaults", "TRUE"
oUser.Put "msExchHomeServerName", "/o=" & Organization & "/ou=" & AdminGroup & "/CN=Configuration/CN=Servers/CN=" & Server
oUser.Put "showInAddressBook", "CN=Default Global Address List,CN=All Global Address Lists,CN=Address Lists Container," & _
"CN=" & Organization & ",CN=Microsoft Exchange,CN=Services,CN=Configuration," & DomainDN
oUser.Put "proxyAddresses", "smtp:" & Alias & "@domain.com"
oUser.SetInfo
oUser.GetInfo
' Enable Account
oUser.AccountDisabled = False
' Set Pwd to be same as 123456
oUser.SetPassword (sPassword)
'Account is not disabled
oUser.AccountDisabled = False
' User must change password at next Logon
oUser.Put "pwdLastSet", CLng(0)
oUser.SetInfo
' Add the user to a group
Dim index As Integer
Dim sEachGroup As String
Do While Len(sGroupName) > 0
'End of list - can't have a string going from 1 to 0
If InStr(sGroupName, ",") <> 0 Then
index = InStr(sGroupName, ",")
Else
index = 50
End If
sEachGroup = Mid(sGroupName, 1, index - 1)
'MsgBox (sEachGroup)
StrobjGroup1 = "LDAP://cn=" & sEachGroup & ",cn=Users,DC=pbmhmr,DC=com"
Set objGroup1 = GetObject(StrobjGroup1)
objGroup1.Add (oUser.ADsPath)
sGroupName = Mid(sGroupName, index + 1)
Loop
' Cleanup
Set oUser = Nothing
MsgBox ("This employee has been added to Active Directory.")