Environment: Windows Server, Access/VBA, Microsoft SQL Server, Active Directory, Exchange
Description: This code creates an email enabled Active Directory user account, and is part of the OneCard system.
Features:
- Unique user created from rules, unique random password
- OU is user type and table driven
- Exchange mailbox store is user type and table driven
- Group membership user type and table driven
- Writes to application event log
- Email administrator upon any error
- Active Directory user account core for LDAP authentication in other applications
Code:
Public Sub NETCreateNewUser(strID As String, strNETUser As String, strNETEmail As String, intStatus2 As Integer)
' Creates actual email-enabled network user account
' Assumes you've successfully already called NETVerifySetup
'
' strID Passed User ID to create account
' strNETUser Returned Network user id
' strNETEmail Returned SMTP email for user id
' intStatus2 Returned 0=I'm OK, <>0 You're not OK
On Error GoTo ErrorBegin
Dim strName As String
strName = "NETCreateNewUser"
Dim objRS As ADODB.Recordset, objRS2 As ADODB.Recordset
Dim objOU As IADsContainer
Dim objUser As IADs
Dim strNETUserPW As String, strUserType As String, strEmpType As String, strExpGradYear As String
Dim strNetUserType As String, datNetExpirationDate As Date
Dim strCN As String
Dim strOU As String, strHomeMdb As String, strUserDN As String, strUType As String, strBR As String
Dim strPeopleSoftID As String, strDefPermList As String, strFullName As String, strTemp As String
Dim strTitle As String, strDepartment As String
Dim intLEN As Integer, intPWSetup As Integer
Dim lngFlag As Long
intStatus2 = 0
If Not bolDBSetup Then Call NETSetup
' ============================================
Debug.Print "Get ID info"
' ============================================
strSQL = "SELECT * FROM OneCardMaster WHERE ID = '" & strID & "'"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, conDbOneCard, adOpenStatic, adLockPessimistic ' write access
With objRS
If (.BOF Or .EOF) Then
strMessage = strName & ": Unable to get OneCardMaster record for ID = " & strID
intStatus2 = -1
GoTo ErrorBegin
Else
strUserType = !UserType
strExpGradYear = Nz(!ExpGradYear, "")
strEmpType = !EmpType
If Len(Trim(!NameFirst)) = 0 Or Len(Trim(!NameLast)) = 0 Then
strMessage = strName & ": Blank first or last name for ID = " & strID
intStatus2 = -1
GoTo ErrorBegin
End If
strPeopleSoftID = Nz(!PeopleSoftID, "")
If Len(Trim(strPeopleSoftID)) = 0 Then
strDefPermList = ""
Else
strDefPermList = conPeopleSoftDefPermList
End If
strNetUserType = !NETUserType
datNetExpirationDate = Nz(!NetExpirationDate, conNullDate)
End If
' Don't close record set, you'll update the sucku' further on
Call GetUtype(strUType, strEmpType, strUserType, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": Unable to get user type = " & strUserType
intStatus2 = -2
GoTo ErrorBegin
End If
' ============================================
Debug.Print "02. Get Unique User ID and support info"
' ============================================
If strNetUserType = "AUTO" Then
Call NETUniqueUser(strID, strNETUser, strCN, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": Unable to execute NETUniqueUser for ID=" & strID
intStatus2 = -1
GoTo ErrorBegin
End If
ElseIf strNetUserType = "PROG" Then
Call NETProgramUser(strUserType, strNETUser, strCN, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": Unable to execute NETProgramUser for ID=" & strID
intStatus2 = -1
GoTo ErrorBegin
End If
Else
strMessage = strName & ": Unable to resolve NetUserType for ID=" & strID
intStatus2 = -2
GoTo ErrorBegin
End If
strNETEmail = strNETUser & "@" & strNETDomain
Call NETNewUserPW(strNETUserPW, intPWSetup, strID, strNETUser, strUType, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": Unable to execute NETNewUserPW for ID=" & strID
intStatus2 = -1
GoTo ErrorBegin
End If
Call NETGetTypeOU(strUType, strExpGradYear, strOU, intStatus)
If intStatus <> 0 Or strOU = "" Then
strMessage = strName & ". Unable to use OU for type " & strUType
If bolOnLine Then MsgBox strMessage
Call DoEventLog("ERR", strName, 100, strMessage, bolEmailNotify, bolOnLine)
strOU = strNETDefOU ' You already verified this exists
intStatus2 = 0 ' Carry on with processing
End If
Call NETGetExchange(strUType, strHomeMdb, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": Unable to execute NETGetExchange for ID=" & strID
intStatus2 = -1
GoTo ErrorBegin
End If
' ============================================
Debug.Print "03. Actually create User ID"
' ============================================
' Position to OU where user will be created
strSQL = "LDAP://" & strOU
Debug.Print strSQL
Set objOU = GetObject(strSQL)
' 07-Jul-2004 FIX If first of last name are blank, error and skip this user
' Create da user
strSQL = "CN=" & strCN
Debug.Print "strSQL: " & strSQL
Set objUser = objOU.create("user", strSQL)
' Network user name
objUser.Put "samAccountName", strNETUser ' network user name (required)
objUser.Put "employeeID", strID ' OneCard ID#
objUser.Put "homeMdb", strHomeMdb ' Exchange mailbox store
objUser.Put "mailnickname", strNETUser ' mailbox name, "alias" (required)
objUser.Put "proxyAddresses", ("SMTP:" & strNETEmail) ' External email address
If Len(strPeopleSoftID) > 0 Then
objUser.Put "employeeNumber", strPeopleSoftID ' PeopleSoft EMPLID
End If
objUser.SetInfo ' Commit
' Enable da user (*** DON'T MOVE THESE UPDATES ******
objUser.SetPassword strNETUserPW ' Password (must meet minimal requirements)
objUser.AccountDisabled = False ' Account is created disabled by default
If intPWSetup = conPWChangeAtLogon Then
objUser.Put "pwdLastSet", 0 ' User must change PW on next logon
ElseIf intPWSetup = conPWNeverExpires Then
objUser.Put "userAccountControl", lngNeverExpires
Else ' default to conPWChangeAtLogon
objUser.Put "pwdLastSet", 0
End If
If datNetExpirationDate <> conNullDate Then
objUser.AccountExpirationDate = datNetExpirationDate ' Set when account expires
End If
objUser.SetInfo ' Commit
' Other fields (*** NOTE, can not update from record set, only variable !!!)
strFullName = Trim(Nz(!NameFirst, "")) & " " & Trim(Nz(!NameLast, ""))
strTemp = Trim(!NameLast)
objUser.Put "sn", strTemp
strTemp = Trim(!NameFirst)
objUser.Put "givenName", strTemp
objUser.Put "DisplayName", strFullName
objUser.SetInfo ' Commit
objUser.Put "mail", strNETEmail ' non-functional, but easy to get to, so keep updated.
objUser.Put "mDBUseDefaults", True ' True=assume exchange storage defaults for user
objUser.Put "msExchIMAddress", strNETEmail
objUser.Put "userPrincipalName", strNETEmail ' convention
objUser.SetInfo ' Commit
strTemp = Nz(!CampusPhone, "")
If Len(strTemp) > 0 Then
objUser.Put "telephoneNumber", strTemp
objUser.SetInfo ' Commit
End If
Call FormatBR(strBR, Nz(!CampusBuilding, ""), Nz(!CampusRoom, ""), intStatus)
strTemp = strBR
If Len(strTemp) > 0 Then
objUser.Put "physicalDeliveryOfficeName", strTemp
objUser.SetInfo ' Commit
End If
strDepartment = Nz(!Department, " ")
If Len(strDepartment) > 3 Then
objUser.Put "department", strDepartment
objUser.SetInfo ' Commit
End If
strTitle = Nz(!Title, " ")
If Len(strTitle) > 3 Then
objUser.Put "title", strTitle
objUser.SetInfo ' Commit
End If
' disable unused Exchange protocols: POP3 & IMAP4
objUser.PutEx ADS_PROPERTY_UPDATE, "protocolSettings", Array("IMAP4§0§1§4§ISO-8859-1§0§1§0§0", "POP3§0§1§4§ISO-8859-1§0§§§")
objUser.SetInfo ' Commit
' Easy mark for when account created
strTemp = "Created: " & Format(Date, "dd-mmm-yyyy")
objUser.PutEx ADS_PROPERTY_UPDATE, "description", Array(strTemp)
objUser.SetInfo ' Commit
Debug.Print "Created user/pw: " & strNETUser & "/" & strNETUserPW
strUserDN = objUser.Get("distinguishedName") ' Save DN ,use later
' ============================================
Debug.Print "04. Update ID"
' ============================================
Call DoDataLog(strName, "UP", "OneCardMaster", "NETUser", Nz(!NETUser, ""), strNETUser, strID, bolOnLine)
Call DoDataLog(strName, "UP", "OneCardMaster", "NETEmail", Nz(!NETEMail, ""), strNETEmail, strID, bolOnLine)
' NET values
!NETUser = strNETUser
!NETEMail = strNETEmail
!NETUserPW = strNETUserPW
!NETNameChange = False
' Other systems (they use email and network account
' !NeedUpdateCBORD = !MakeUserCBORD (doesn't use email)
!NeedUpdateInnovative = !MakeUserInnovative
!SubSystemUpdate = Now()
!LastUpdateNET = Now()
!NeedUpdateNET = False
.Update
End With
Set objRS = Nothing
' ============================================
Debug.Print "05. Add to group(s)"
' ============================================
Call NETAddUser2Groups(strUserDN, strUType, strExpGradYear, intStatus)
If intStatus <> 0 Then
strMessage = strName & ": NETAddUser2Groups failed for ID=" & strID
If bolOnLine Then MsgBox strMessage
Call DoEventLog("ERR", strName, 100, strMessage, bolEmailNotify, bolOnLine)
intStatus2 = 0 ' Carry on with processing
End If
' ============================================
Debug.Print "06. Supplimental user setup"
' ============================================
' Post new user processes: All users
Call DoNETQue(strID, "Portal", bolOnLine)
Call DoNETQue(strID, "UDrive", bolOnLine)
Call DoNETQue(strID, "SEmail", bolOnLine)
' special stuff for types of users
If strUserType = "SOKASTUDENT" Then
Call DoNETQue(strID, "Learn", bolOnLine)
Call DoNETQue(strID, "Angel", bolOnLine)
ElseIf (strUserType = "STAFF-FACULTY" Or strUserType = "CONTRACTOR") Then ' Heads up this happened (employees only)
Call cmdSendMail("Admin", "New network user created: " & strNETUser & "" & strFullName, 0, _
"ID: " & strID & "; Type: " & strUserType & "; Name: " & strFullName & vbLf & _
"Department: " & strDepartment & "; Title: " & strTitle & vbLf & _
"NetID: " & strNETUser & "; Password: " & strNETUserPW)
Call DoNETQue(strID, "HD-SET-USE", bolOnLine) ' Help Desk, user
Call DoNETQue(strID, "HD-SET-PHO", bolOnLine) ' Help Desk, phone
End If
ExitBegin:
Exit Sub
ErrorBegin:
' Err.Number = -2147467259, you are not Domain Admin
' Err.Number = -2147016651, password set fails if does not meet rules
' Err.Number = -2147019886 The user already exists
If intStatus2 = 0 Then ' General message
strMessage = "Error in " & strName & " " & Err.Number & " " & Err.Description & " on strID = " & Nz(strID, "")
intStatus2 = -100 ' I'm NOT OK
End If
If bolOnLine Then MsgBox strMessage
Call DoEventLog("ERR", strName, 500, strMessage, True, bolOnLine)
GoTo ExitBegin
End Sub
No comments:
Post a Comment