OC.SendAppMail: New user introductory email

Author: Robert Lawson
Environment: Windows Server, Access/VBA, Microsoft SQL Server
Description: This code sends a new user an introductory orientation email for both email and phone/voice mail. The wording was crafted in conjunction with User Services to serve as basis for orientation training. For MS Exchange email, this email also forces the mailbox setup (known issue/consideration). The email orientation is sent upon account/mailbox creation (this also forces the Exchange mailbox setup). The phone orientation is sent when the phone is setup (when the Active Directory phone number is synced with the Cisco Unity system, see OC.CPRebuild).
Features:
- HTML form email, designed in DreamWeaver
- Personalized with variable substitution
- bcc copy to administrator and help desk
Samples:





Code:

Public Sub SendAppMail(strID As String, strUType As String, strEmailType As String, bolOnLine As Boolean, intStatus2 As Integer)

' Sends email to users

' 11-Sept-2006  Robert Lawson Creation date

' 27-Dec-2007 Robert Lawson  Updated for ADO



' strID                Passed      OneCard ID number

' strUType             Passed      User Type from GetUtype function

' strEmailType         Passed      Type of email: "NewEmailUser", "NewPhoneUser"

' bolOnLine            Passed      TRUE=you're interactive

' intstatus2            Returned    0=OK, <>0 You're not OK

On Error GoTo ErrorBegin

Dim strName As String

strName = "SendAppMail"



Dim strNETEmail As String, strFullName As String

Dim strLDCode As String, strCampusPhone As String

Dim strFrom As String, strTo As String, strBCC As String, strSubject As String, strBody As String

Dim strFile As String, strLine As String, strExt



Const conFullName = "#FULLNAME#"

Const conPhoneNumber = "#PHONENUMBER#"

Const conLDCode = "#LDCODE#"

Const conEmail = "#EMAIL#"



Const conEmailUserAdmin = "Robert.Lawson@uni.edu"

Const conPhoneUserAdmin = "winky@uni.edu,Robert.Lawson@uni.edu,sleepy@uni.edu"

Const conOneCardAdmin = "admin@uni.edu"



intStatus2 = 0

strMessage = conNoMessage



Call LoadSysDbconn(intStatus)

If intStatus <> 0 Then

    strMessage = "Error calling LoadSysDbconn."

    Err.Raise (vbObjectError + 10), , strMessage

    GoTo ErrorBegin

End If

strTodayDate = Format(Now(), "mm/dd/yyyy")



' Valid type?

If Not (strEmailType = conEmailUser Or strEmailType = conPhoneUser) Then

    strMessage = strName & ":invalid EmailType = " & strEmailType

    intStatus2 = -10

    GoTo ErrorBegin

End If



' Get person's info

strSQL = "SELECT * FROM OneCardMaster WHERE ID = '" & strID & "'"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, conDbOneCard, adOpenDynamic, adLockReadOnly ' read access

With objRS

If (.BOF Or .EOF) Then

    strMessage = strName & ": Unable to get OneCardMaster record for ID = " & strID

    intStatus2 = -20

    GoTo ErrorBegin

Else

    strNETEmail = Nz(!NETEMail, "")

    strFullName = Trim(Nz(!NameFirst, "")) & " " & Trim(Nz(!NameLast, ""))

    strCampusPhone = Trim(Nz(!CampusPhone, ""))

End If

End With

Set objRS = Nothing



' Verify they have email address

If (Len(strNETEmail) = 0) Then

    strMessage = strName & ": No email for ID = " & strID

    intStatus2 = -30

    GoTo ErrorBegin

End If



' Get Long Distance Code ***********************

If strEmailType = conPhoneUser Then

    'strExt = Right(strCampusPhone, 4)

    'strSQL = "SELECT code FROM FACInfo WHERE description =  " & """" & strExt & """"

    'Debug.Print strSQL

    'Set rs = Db.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)

    'If (rs.BOF Or rs.EOF) Then

    '    StrMessage = strName & ": Unable to get Long Distance code for ID  = " & strID

    '    intstatus2 = -1

    '    GoTo ErrorBegin

    'End If

    'strLDCode = rs!code

    'rs.Close

    strLDCode = " "

End If



' Set correct variables for email type

If strEmailType = conEmailUser Then

    strFile = "D:\Data\doc\OneCardNoticeMail.htm"

    strTo = strNETEmail

    strFrom = conOneCardAdmin

    strBCC = conEmailUserAdmin

    strSubject = "Your email information" & strFullName

ElseIf strEmailType = conPhoneUser Then

    strFile = "D:\Data\doc\OneCardNoticePhone.htm"

    strTo = strNETEmail

    strFrom = conOneCardAdmin

    strBCC = conPhoneUserAdmin

    strSubject = "Your phone information" & strFullName

End If



' Open file for email body (it must be in HTML format)

strBody = ""

Open strFile For Input As #1

Do Until EOF(1)

  Line Input #1, strLine

  strBody = strBody & strLine

Loop

Close #1

' Debug.Print strBody



' Substitute variables

If strEmailType = conEmailUser Then ' conEmail

    strBody = Replace(strBody, conFullName, strFullName)

    strBody = Replace(strBody, conEmail, strNETEmail)

ElseIf strEmailType = conPhoneUser Then

    strBody = Replace(strBody, conFullName, strFullName)

    strBody = Replace(strBody, conPhoneNumber, strCampusPhone)

    strBody = Replace(strBody, conLDCode, strLDCode)

End If



Call SendHTMLmail(strFrom, strTo, strBCC, strSubject, strBody, intStatus)

Debug.Print "intStatus = " & intStatus



' Write to trans log table

Call DoDataLog(strName, "IN", "SUB-USER", strEmailType & " email notification", "", strID, strID, bolOnLine)



ExitBegin:

    Exit Sub



ErrorBegin:

    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

OC.CreatePSLearnUser: Create PeopleSoft Campus Solutions user

Author: Robert Lawson
Environment: Windows Server, Access/VBA, Microsoft SQL Server, PeopleSoft
Description: This code creates a PeopleSoft Campus Solutions user for a student, and is part of the OneCard system. All students require this user and are given the same access. This account is created in sync with the Active Directory account, so that LDAP authentication can be readily accomplished.
Features:
- Writes to application event log
- Email administrator upon any error
- PeopleSoft user created to work with LDAP authentication
Sample:

Code:

Public Sub CreatePSLearnUser(strID As String, strUType As String, bolOnLine As Boolean, intStatus2 As Integer)

' Creates PeopleSoft Learning Solutions 8.8 user

' 08-Jun-2006  Robert Lawson Creation date (Learning Solutions 8.1/PeopleTools 8.22)

' 23-Apr-2008  Robert Lawson Updated for Campus Solutions 9.0

' **** NOTE, this is centric to student in AV, any other user must look closely!!! ***************



' strID                Passed      OneCard ID number

' strUType             Passed      User Type from GetUtype function

' bolOnLine            Passed      TRUE=you're interactive

' IntStatus2           Returned    0=OK, <>0 You're not OK

On Error GoTo ErrorBegin

Dim strName As String

strName = "CreatePSLearnUser"



Dim intStatus As Integer

Dim objRS As ADODB.Recordset, objRS2 As ADODB.Recordset

Dim strNETUser As String, strNETEmail As String, strFullName As String, strPeopleSoftID As String

Dim strEmailType As String, strGroupRole As String, strOprClass As String, strEnrlAccessGroup As String



intStatus2 = 0

strMessage = conNoMessage



Call LoadSysDbconn(intStatus)

If intStatus <> 0 Then

    strMessage = "Error calling LoadSysDbconn."

    Err.Raise (vbObjectError + 10), , strMessage

    GoTo ErrorBegin

End If

strTodayDate = Format(Now(), "mm/dd/yyyy")

' Get person's info

strSQL = "SELECT * FROM OneCardMaster WHERE ID = '" & strID & "'"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, conDbOneCard, adOpenDynamic, adLockReadOnly ' read access

With objRS

If (.BOF Or .EOF) Then

    strMessage = strName & ": Unable to get OneCardMaster record for ID = " & strID

    intStatus2 = -10

    GoTo ErrorBegin

Else

    strNETUser = Nz(!NETUser, "")

    strNETEmail = Nz(!NETEMail, "")

    strPeopleSoftID = Nz(!PeopleSoftID, "")

    strFullName = Trim(Nz(!NameFirst, "")) & " " & Trim(Nz(!NameLast, ""))

End If

End With

Set objRS = Nothing



' Can not create user without these key items!

If Len(strNETUser) = 0 Or Len(strNETEmail) = 0 Then

    strMessage = strName & ":Unable to get NETUser or NETEmail for = " & strID

    intStatus2 = -20

    GoTo ErrorBegin

End If



' Figure out which role to give them

If strUType = "STAFF" Then

    strGroupRole = "?"

    strEnrlAccessGroup = "?"

    strOprClass = "?"

ElseIf strUType = "FACULTY" Then

    strGroupRole = "?"

    strEnrlAccessGroup = "?"

    strOprClass = "?"

ElseIf strUType = "SOKASTUDENT" Then

    strGroupRole = conGroupRoleStudent

    strEnrlAccessGroup = conEnrlAccessGroupStudent

    strOprClass = conOprClassStudent9

Else

    strGroupRole = "?"

    strEnrlAccessGroup = "?"

    strOprClass = "?"

End If



' This type is not yet figured out

If strGroupRole = "?" Then

    strMessage = strName & ": Unable to get role for type = " & strUType & " for ID = " & strID

    intStatus2 = -25

    GoTo ErrorBegin

End If



' See if user already setup

strSQL = "SELECT * FROM PSOPRDEFN WHERE OPRID = '" & strNETUser & "'"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, conDbPSLearn, adOpenDynamic, adLockReadOnly ' read access

If Not (objRS.BOF Or objRS.EOF) Then

    strMessage = strName & ": User already setup in PSOPRDEFN for ID = " & strID

    intStatus2 = -30

    GoTo ErrorBegin

End If

Set objRS = Nothing



' --- Add PSOPRDEFN (actual user)

Set objRS = CreateObject("ADODB.Recordset")

strSQL = "PSOPRDEFN"

Debug.Print strSQL

objRS.Open strSQL, conDbPSLearn, adOpenStatic, adLockPessimistic ' write access



With objRS

.AddNew

!OPRID = strNETUser

!Version = 1

!OPRDEFNDESC = strFullName

!EMPLID = strPeopleSoftID

!EMAILID = strNETEmail

!OPRCLASS = strOprClass

!ROWSECCLASS = strOprClass

!OPERPSWD = conLearnOPERPSWD

!ENCRYPTED = 1

!SYMBOLICID = conLearnSYMBOLICID

!LANGUAGE_CD = "ENG"

!MULTILANG = 0

!CURRENCY_CD = "USD"

!LASTPSWDCHANGE = strTodayDate

!ACCTLOCK = 0

!PRCSPRFLCLS = strOprClass

!DEFAULTNAVHP = conStdDEFAULTNAVHP

!FAILEDLOGINS = 0

!EXPENT = 0

!OPRTYPE = 0

!USERIDALIAS = conBlank

!LASTSIGNONDTTM = Null

!LASTUPDDTTM = strTodayDate

!LASTUPDOPRID = conPLearnLASTUPDOPRID

!PTALLOWSWITCHUSER = 0

.Update

End With

Set objRS = Nothing



' ----- Add PSOPRALIAS (EMPLID reference)

Set objRS = CreateObject("ADODB.Recordset")

strSQL = "PSOPRALIAS"

Debug.Print strSQL

objRS.Open strSQL, conDbPSLearn, adOpenStatic, adLockPessimistic ' write access



With objRS

.AddNew

!OPRID = strNETUser

!OPRALIASTYPE = "EMP"

!OPRALIASVALUE = strPeopleSoftID

!SETID = conBlank

!EMPLID = strPeopleSoftID

!CUST_ID = conBlank

!VENDOR_ID = conBlank

!APPLID = conBlank

!CONTACT_ID = conBlank

!PERSON_ID = conBlank

!EXT_ORG_ID = conBlank

!BIDDER_ID = conBlank

!EOTP_PARTNERID = 0

.Update

End With

Set objRS = Nothing



' ----- Add PS_ROLEXLATOPR

Set objRS = CreateObject("ADODB.Recordset")

strSQL = "PS_ROLEXLATOPR"

Debug.Print strSQL

objRS.Open strSQL, conDbPSLearn, adOpenStatic, adLockPessimistic ' write access



With objRS

.AddNew

!ROLEUSER = strNETUser

!DESCR = strFullName

!OPRID = strNETUser

!EMAILID = strNETEmail

!FORMID = conBlank

!WORKLIST_USER_SW = "Y"

!EMAIL_USER_SW = "Y"

!FORMS_USER_SW = "Y"

!EMPLID = strPeopleSoftID

!ROLEUSER_ALT = conBlank

!ROLEUSER_SUPR = conBlank

!EFFDT_FROM = Null

!EFFDT_TO = Null

.Update

End With

Set objRS = Nothing

Debug.Print strSQL



' ----- Add PSROLEUSER (gives security role)

Set objRS = CreateObject("ADODB.Recordset")

strSQL = "PSROLEUSER"

Debug.Print strSQL

objRS.Open strSQL, conDbPSLearn, adOpenStatic, adLockPessimistic ' write access



With objRS

.AddNew

!ROLEUSER = strNETUser

!ROLENAME = conGroupRoleStudent9  ' 1

!DYNAMIC_SW = "N"

.Update

.AddNew

!ROLEUSER = strNETUser

!ROLENAME = "EOPP_USER"   ' 2

!DYNAMIC_SW = "N"

.Update

.AddNew

!ROLEUSER = strNETUser

!ROLENAME = "SUA_PAPP_USER"   ' 3

!DYNAMIC_SW = "N"

.Update

.AddNew

!ROLEUSER = strNETUser

!ROLENAME = "GENERAL_PEOPLESOFTUSER" ' 4

!DYNAMIC_SW = "N"

.Update

.AddNew

!ROLEUSER = strNETUser

!ROLENAME = "SUA_Standard Non-Page Perms" ' 5

!DYNAMIC_SW = "N"

.Update

End With

Set objRS = Nothing



' ----- Add PS_OPR_DEF_TBL_CS (enables self-serve)

Set objRS = CreateObject("ADODB.Recordset")

strSQL = "PS_OPR_DEF_TBL_CS"

Debug.Print strSQL

objRS.Open strSQL, conDbPSLearn, adOpenStatic, adLockPessimistic ' write access



With objRS

.AddNew

!OPRID = strNETUser

!SETID = conBlank

!INSTITUTION = "SUA"

!BUSINESS_UNIT = conBlank

!ACAD_GROUP = conBlank

!Subject = conBlank

!STRM = conBlank

!ACAD_PROG = conBlank

!ACAD_PLAN = conBlank

!ACAD_SUB_PLAN = conBlank

!AID_YEAR = conBlank

!ACAD_CAREER = conBlank

!SETID_FACILITY = conBlank

!SETID_CAREER = conBlank

!ENRL_ACCESS_ID = conBlank

!OVRD_CLASS_LIMIT = "N"

!OVRD_UNIT_LOAD = "N"

!OVRD_CLASS_PRMSN = "N"

!OVRD_REQUISITES = "N"

!OVRD_TIME_CNFLCT = "N"

!WAIT_LIST_OKAY = "N"

!OVRD_ENRL_ACTN_DT = "N"

!CARRY_ID = "Y"

!ADM_RECR_CTR = conBlank

!ADM_APPL_CTR = conBlank

!CASHIER_OFFICE = conBlank

!DEPTID = conBlank

!ADMIT_TYPE = conBlank

!CAMPUS = conBlank

!OUTPUT_DEST = conBlank

!ACADEMIC_LEVEL = conBlank

!ADM_APPL_METHOD = conBlank

!TSCRPT_TYPE = conBlank

!ENRL_ACCESS_GROUP = strEnrlAccessGroup

!HOUSING_INTEREST = conBlank

!FIN_AID_INTEREST = "N"

!TRANSCRIPT_TYPE = conBlank

!DATA_MEDIUM_RCVD = conBlank

!DATA_SOURCE_RCVD = conBlank

!LAST_SCH_ATTEND = conBlank

!GRADUATION_DT = Null

!INSTITUTION_SET = "SUA"

!ISET_OVRD = "SUA"

!SEV_SCHOOL_CD = conBlank

!SEV_PRG_NBR = conBlank

!PRINTER_NAME = conBlank

!SAA_TSCRPT_TYPE = conBlank

.Update

End With

Set objRS = Nothing



' Write to trans log table, table = SUB-USER, field = PeopleSoft Portal

Call DoDataLog(strName, "IN", "SUB-USER", "PeopleSoft Learn", "", strID, strID, bolOnLine)



ExitBegin:

    Exit Sub



ErrorBegin:

    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

OC.CPRebuild: Sync AD phone with CISCO Unity

Author: Robert Lawson
Environment: Windows Server, Access/VBA, Microsoft SQL Server, Exchange
Description: This code is part of the Active Directory and Cisco Unity phone number synchronization. This code establishes the relationship between the AD account and the Unity voicemail number, which is considered the same as phone number. The results are then compared, in another piece of code, to the existing phones number. If the old phone number is not set, then this is considered a newly established phone number and an introductory email is sent to the user: see OC.SendAppMail.
Features
- Phone number shows in Exchange email address book
- Converts 4 digit extension into common format with area code: aaa-ppp-dddd
- Newly assigned phone number initiates introductory email to user.
Code:

Public Sub CPRebuild(intStatus As Integer)
' Rebuild the phone table

' intStatus            Returned    0=OK, <>0 You're not OK

On Error GoTo ErrorBegin
Dim strName As String
strName = "CPRefresh"

' Local
Dim con As ADODB.Connection
Dim Com As ADODB.Command
Dim rx As ADODB.Recordset
Dim strDomain As String
Dim strsamAccountName As String, strSMTPUser As String
Dim Kount As Double

intStatus = 0 ' I'm OK
If Not bolDBSetup Then Call CPSetup

Set con = CreateObject("ADODB.Connection")
Set Com = CreateObject("ADODB.Command")
'Opening the connection
con.Provider = "ADsDSOObject"  'this is the ADSI OLE-DB provider name
con.Open "Active Directory Provider"
Set Com.ActiveConnection = con 'Create a command object for this connection

strSQL = "SELECT * FROM CampusPhoneDetail"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, conDbOneCard, adOpenStatic, adLockPessimistic ' write access
With objRS

' ciscoEcsbuTransferId = transferid, ciscoEcsbuDtmfId=extension
' strNETADDomain = "OU=Users,OU=Aliso Viejo,DC=soka,DC=edu"
' only get those with an extension
strSQL = "SELECT samAccountName, employeeID, ciscoEcsbuDtmfId" & _
" FROM 'LDAP://" & strNETADDomain & "'" & " WHERE ciscoEcsbuDtmfId = '*' AND homeMDB='*'"

Debug.Print strSQL
Com.CommandText = strSQL
Set rx = Com.Execute

Kount = 0
If (rx.BOF Or rx.EOF) Then
    intStatus = 10
    strMessage = strName & ": no extensions found in Active directory."
    GoTo ErrorBegin
End If

Do While Not (rx.BOF Or rx.EOF)
    Kount = Kount + 1
    strExtension = Trim(Nz(rx.Fields("ciscoEcsbuDtmfId"), ""))
    strNETUser = Nz(rx.Fields("samAccountName"), "")
    ' Debug.Print "samAccountName " & rx.Fields("samAccountName")
    If Len(Trim(strExtension)) > 0 Then  ' Only get Unity extensions
        strNETUser = Nz(rx.Fields("samAccountName"), "")
        strID = Nz(rx.Fields("employeeID"), "")
      
        Call CPPhone(intStatus) ' CRule, Extension, PhoneNumber
        If intStatus = -2 Then
            ' OK, just not classified, but error was reported, keep on truckin'
        ElseIf intStatus <> 0 Then
            intStatus = 22
            strMessage = strName & ": CPPhone failed on NETUser = " & strNETUser
            GoTo ErrorBegin
        End If
        .AddNew
        !NETUser = strNETUser
        !ID = strID
        !CRule = strCRule
        !Extension = strExtension
        !PhoneNumber = strPhoneNumber
        .Update
    End If
    rx.MoveNext
Loop
End With
Set objRS = Nothing
rx.Close

ExitBegin:
    Debug.Print "End of " & strName & " proceseed records: " & Kount
    Exit Sub

ErrorBegin:
    If intStatus = 0 Then ' General message
        strMessage = "Error in " & strName & " " & Err.Number & " " & Err.Description
        intStatus = -100 ' I'm NOT OK
    End If
    If bolOnLine Then MsgBox strMessage
    Call DoEventLog("ERR", strName, 500, strMessage, True, bolOnLine)
    GoTo ExitBegin
End Sub

OC.NETCreateNewUser: Create new AD user

Author: Robert Lawson
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

OC.basLinkTables: Link Database Tables

Author: Robert Lawson
Environment: Windows Server, Access/VBA, Microsoft SQL Server
Description: This code module links database tables to the MS Access database file, and is part of the OneCard system. The tables names and access information are stored in local tables, including production and test access. MS Access requires tables to be mapped for use with forms, queries or reports. Note that the same access information is also used for ODBC-less access. Use within Immediate Window: call linktables("PROD")
Features:
- Quick and easy way to move between test and production data sets
- Table driven, easy to add and remove references
- Connection for test and production databases is table driven
Sample Data:



Code:

Option Compare Database

Option Explicit

' basLinkTables



Dim strName As String

Dim strMessage As String

Dim strSQL As String

Dim intStatus As Integer



Dim strConnect As String     ' Connect string

Const conNoMessage = "?"



Public Sub LinkTables(strDBname As String)

' Link data tables

' Name                        Description

' DBname       Passed    DB name set: PROD, TEST

' 27-JUL-2001  Robert Lawson

' 03-Jan-2008 Robert Lawson  Rewrote



strName = "LinkTables"

On Error GoTo ErrorBegin



' System

Dim objConn As ADODB.Connection

Dim objRS As ADODB.Recordset, objRS2 As ADODB.Recordset, objRS3 As ADODB.Recordset

Dim strFile As String



' Local

Dim intStatus As Integer

Dim strSource  As String, strdbConn As String

Dim strDatabase As String, strServer As String, strConn As String

Dim strTableName As String, strLinkName As String



strMessage = conNoMessage

Set objConn = CurrentProject.Connection

' ============================================

Debug.Print "01. Check if passed DB OK"

' ============================================

If Len(Trim(Nz(strDBname, ""))) = 0 Then

    MsgBox "ERR: No databse passed"

    GoTo ExitBegin

End If



strSQL = "SELECT * FROM SysDBConn WHERE DBName = '" & strDBname & "'"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access

With objRS



If (.EOF Or .BOF) Then

    MsgBox "ERR: Invalid databse passed"

    GoTo ExitBegin

End If

End With

Set objRS = Nothing



' ============================================

Debug.Print "02. Remove existing links"

' ============================================

Call RemoveLinks(intStatus)

If intStatus <> 0 Then

    GoTo ExitBegin

End If



' ============================================

Debug.Print "03. Link Tables"

' ============================================

strSQL = "SELECT * FROM SysDBConn WHERE DBName = '" & strDBname & "'"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access

With objRS



Do Until .EOF

    strSource = objRS!Source

    strServer = objRS!SERVER

    strDatabase = objRS!Database

    strConn = objRS!ConnLink

    ' ODBC;DRIVER=SQL Server;SERVER=ServerName;DATABASE=DBname;Trusted_Connection=Yes

    strdbConn = strConn & ";SERVER=" & strServer & ";DATABASE=" & strDatabase



    strSQL = "SELECT * from SysTableLink WHERE SOURCE = """ & strSource & """"

    Debug.Print strSQL

    Set objRS2 = CreateObject("ADODB.Recordset")

    objRS2.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access



    Do Until objRS2.EOF

        strTableName = objRS2!TableName

        strLinkName = Nz(objRS2!LinkName, "")

    

        Call LinkTable(strdbConn, strTableName, strLinkName, intStatus)

        If intStatus <> 0 Then GoTo ExitBegin



        objRS2.MoveNext

    Loop

    Set objRS2 = Nothing

    .MoveNext

Loop

End With

Set objRS = Nothing



' ============================================

Debug.Print "04. Update SysInfo"

' ============================================

strSQL = "SELECT * FROM SysInfo"

Debug.Print strSQL

Set objRS = CreateObject("ADODB.Recordset")

objRS.Open strSQL, objConn, adOpenStatic, adLockPessimistic ' write access

With objRS

!DBname = strDBname

.Update

End With

Set objRS = Nothing



ExitBegin:

    Debug.Print strName & " completed successfully for " & strDBname

    Exit Sub



ErrorBegin:

    MsgBox "Error in " & strName & " " & Err.Number & " " & Err.Description

    GoTo ExitBegin

End Sub

Public Sub LinkTable(strDBsource As String, strTableName As String, strLinkName As String, intStatus As Integer)

' link table

' 04-JUL-2001 Robert Lawson  Creation Date

' 03-Jan-2008 Robert Lawson  Rewrote



' Name                        Description

' strDBsource       Passed    Source where table is

' strTableName      Passed    Table name

' strLinkName       Passed    Name to use to link table, if blank, use TableName

' intStatus         Returned  Status, 0=OK, <>0 you are not OK

'

strName = "LinkTable"

On Error GoTo ErrorBegin



Dim Db As Database

Dim tdf As TableDef

Dim strLinkedTableName As String



intStatus = 0 ' We've only just begun

Set Db = CurrentDb()



' Figure linked table name

If Len(Trim(strLinkName)) = 0 Then

    strLinkedTableName = strTableName

Else

    strLinkedTableName = strLinkName

End If



' Relink'em der logic

Set tdf = Db.CreateTableDef(strLinkedTableName)

With tdf

.Connect = strDBsource

.SourceTableName = strTableName

.Attributes = dbAttachSavePWD



Debug.Print "Name: "; .Name

Debug.Print "Connect: "; .Connect

Debug.Print "SourceTableName:"; .SourceTableName

Debug.Print "Attributes:"; .Attributes

End With



Db.TableDefs.Append tdf



ExitBegin:

    Exit Sub



ErrorBegin:

   intStatus = -100

   MsgBox "Error in " & ":" & strName & " " & Err.Number & " " & Err.Description

   GoTo ExitBegin

End Sub

Public Sub RemoveLinks(intStatus As Integer)

' Remove all links

'

' 01-Jan-2008 Robert Lawson  Creation Date

' Name                        Description

' intStatus         Returned  Status, 0=OK, <>0 you are not OK

strName = "RemoveLinks"

On Error GoTo ErrorBegin



Dim Db As Database

Dim tdf As TableDef

Dim strLinkedTableName As String, strConn As String



intStatus = 0 ' We've only just begun

Set Db = CurrentDb()



For Each tdf In Db.TableDefs

    strLinkedTableName = tdf.Name

    strConn = Nz(tdf.Connect, "")

    If Left(strLinkedTableName, 4) <> "MSys" Then

        Debug.Print "Name: " & strLinkedTableName

        Debug.Print "SourceTableName: " & tdf.SourceTableName

        Debug.Print "Connect: " & tdf.Connect

        Debug.Print "Attributes = " & tdf.Attributes

        If Len(Trim(strConn)) > 0 Then

            Debug.Print "Removing link for: " & strLinkedTableName

            DoCmd.DeleteObject acTable, strLinkedTableName

        End If

    End If

Next



ExitBegin:

    Exit Sub



ErrorBegin:

   intStatus = -100

   MsgBox "Error in " & ":" & strName & " " & Err.Number & " " & Err.Description

   GoTo ExitBegin

End Sub

OC.CreateInnovative: Create library patron records

Author: Robert Lawson
Environment: Windows Server, Access/VBA, Microsoft SQL Server, Innovative
Description: This code does the library patron maintenance: add, update and de-activate. The library system, Innovative, accepts a ascii file, pre-formatted: MARC format.
Features:
- Patron can use their ID card magnetic strip to check out books
- Patron access is synchronized with exit policy
- Patron privileges are determined by this coding
Code:

Public Sub CreateInnovative(bolOnLine As Boolean, intStatus2 As Integer, dblCount As Double)
' Create Innovative patron MARC record file
'
' 04-JUL-2001 Robert Lawson  Creation Date
'                            Innovative, INNOPAC User Manual, "Load PATRON recors from tape or IFTS"
'                            r 2000, 6/28/2001
' 08-OCT-2001 Robert Lawson  Added yyyyymmdd logic
' 12-AUG-2002 Robert Lawson  Chngd PCODE1 update per library (RS), added PCODE2 & PCODE3
' 15-Jul-2003 Robert Lawson  If coded MakeUserInnovative = False, then set to inactive
' 17-Jul-2003 Robert Lawson  Updated to Release 2002, Phase 2 specs (added PCODE4)
' 05-Aug-2003 Robert Lawson  Update header record for library code and block code
'                            mblock inactive from from i to b, library from MCIRC to mcirc
' 07-Aug-2003 Robert Lawson  Removed PCODE4, added proper codes for PCODE1, PCOD2, Message Code
' 02-Mar-2004 Robert Lawson  Changed default PCODE2 from 'c' to '-' per Devin Castel
' 08-Apr-2004 Robert Lawson  Add suffix to last name, the "JR" fix
' 04-Jan-2005 Robert Lawson  Added DoDataLog call when user setup
' 12-Apr-2006 Robert Lawson  Changed Active/Disable logic to use date, as Block Code in IIS no worky
' 05-May-2007 Robert Lawson  Added SWC logic
' 27-Dec-2007 Robert Lawson  Updated for ADO
' 08-Jan-2008 Robert Lawson  Removed "access pending" logic

' Name                        Description
' IntStatus2         Returned  Status, 0=OK, <>0 you are not OK
' dblCount          Returned  Number of records processed

' Questions
' 3. How do you know max length for each field?
' 4. User type ?
' 6. How do I know field max length size?
' 7. Required other fields by application (john & vendor): patron type, home library,
' 8. deletion code: what is letter for '070', have more than 'd'elete status?  Open, inactive?

' Notes
' 1. Using "Format3: Text File Image."

strName = "CreateInnovative"
On Error GoTo ErrorBegin

' System
Dim intStatus As Integer
Dim objRS As ADODB.Recordset, objRS2 As ADODB.Recordset
Dim strFile As String

' Local
Dim bolUpdate As Boolean, bolPatronActive As Boolean, bolEmailEventLog As Boolean
Dim Kount As Double
Dim strRec As String, strStatus As String, strPatron As String, strID As String
Dim strPCODE1 As String, strPCODE2 As String, strPCODE3 As String, strFieldCode As String
Dim strMessageCode As String, strNameTemp As String, strDateStatus As String
Const conHomeLibrary = "mcirc"
Const conDateActive = "04-11-27"  ' A new beginning
Const conDateDisable = "04-11-00" ' When I expire

intStatus2 = 0 ' I'm OK
Call DoEventLog("PRO", strName, 0, "Begin", False, bolOnLine)
strMessage = conNoMessage

Call LoadSysDbconn(intStatus)
If intStatus <> 0 Then
    strMessage = "Error calling LoadSysDbconn."
    Err.Raise (vbObjectError + 10), , strMessage
    GoTo ErrorBegin
End If
' ============================================
Debug.Print "01. Get file information"
Step_01:
' ============================================
strSQL = "SELECT FileInnovative from SysInfo"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, conDbOneCard, adOpenDynamic, adLockReadOnly ' read access

With objRS
If (.BOF Or .EOF) Then
    strMessage = "Unable to get SysInfo record"
    intStatus2 = -1
    GoTo ErrorBegin
ElseIf Nz(RTrim(!FileInnovative), "") = "" Then
    strMessage = strName & ": SysInfo record for FileName is null"
    intStatus2 = -2
    GoTo ErrorBegin
End If

strFile = !FileInnovative
strFile = Replace(strFile, "yyyymmdd", Format(Date, "yyyymmdd"))
' strFile = "C:\TEMP\InnovativeExport.txt"  ' *********** DEBUG ****************
If FileExists(strFile) Then
Debug.Print strFile
    strMessage = strName & ": Export file already exists: " & strFile
    intStatus2 = -3
    GoTo ErrorBegin
End If
End With
Set objRS = Nothing

' ============================================
Debug.Print "02. Main loop"
Step_02:
' ============================================
strSQL = "SELECT * FROM OneCardMaster WHERE NeedUpdateInnovative = 1"  ' 1=True
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, conDbOneCard, adOpenStatic, adLockPessimistic ' write access

With objRS
' Get record count (.RecordCount property don't work)
Do Until .EOF
    Kount = Kount + 1
    .MoveNext
Loop
Debug.Print "Kount = " & Kount

If Kount = 0 Then
' 07-July-2004 FIX Write blank files, lets user know there are no records
    strMessage = strName & ": Warning.  Zero records to process."
    If bolOnLine Then MsgBox strMessage
    Call DoEventLog("PRO", strName, 10, strMessage, False, bolOnLine)
    GoTo ExitBegin
End If
.MoveFirst ' You moved BOF when doing Kount

' Create file if there are records or not (leaves trail of what ya did)
Close  ' Close anything else open
Open strFile For Output As #1  ' Purge old file 1st

' Zero Field record layout, from Innovative on 23-AUG-2001
'Field code                 1 char.(a zero)
'Patron type                3 digits (000 to 255), e.g. "003"
'Patron code 1              1 char. e.g. "a"
'Patron code 2              1 char. e.g. "b"
'Patron code 3              3 digits (000255), e.g. "002"
'Patron's home library code 5 chars. e.g. "art  "
'Patron message code        1 char. e.g. " "   (blank space)
'Patron block code          1 char.  e.g. " "
'Patron exp. date           8 chars. (mmddyy), e.g. "02-15-90"

' Detail: code of what is, followed by value itself.  Each value is variable length
Do Until .EOF
    strID = !ID
    ' status (block code), must be 1
    If !MakeUserInnovative = False Or (IsDate(!ExpirationDate) And !ExpirationDate <= Date) Then
        bolPatronActive = False
        strDateStatus = conDateDisable
    Else
        bolPatronActive = True
        strDateStatus = conDateActive
    End If
    
    ' Patron Type (ties to cirulation rule), must be 3
    strFieldCode = "0" ' Plug value
    strPCODE1 = "-"  ' Unclassified
    strPCODE2 = "-"  ' Not community (public)
    strPCODE3 = "000"
    strMessageCode = "-" ' Default
    strStatus = "-" ' Hard code to "valid" Patron Block Code, as doesn't work
    
    If !UserType = "SOKASTUDENT" Then
        strPatron = "007"
        Select Case !AcadLevel
            Case "FRSH"
              strPCODE1 = "1"
            Case "SOPH"
              strPCODE1 = "2"
            Case "JUNR"
              strPCODE1 = "3"
            Case "SENR"
              strPCODE1 = "4"
            Case "POST"
              strPCODE1 = "g"
            Case "GRAD"
              strPCODE1 = "g"
            Case Else
              strPCODE1 = "-"  ' No idea
         End Select
    ElseIf !UserType = "STAFF-FACULTY" Then
        strPatron = "006"
        strPCODE1 = "s" ' Staff
        If !EmpType = "PROF" Then strPCODE1 = "f"  ' Faculty
    ElseIf !UserType = "CONTRACTOR" Then
        strPatron = "006"
        strPCODE1 = "s" ' 07-Aug-2003, lump with staff
        strMessageCode = "a" ' 07-Aug-2003, check address flag
    ElseIf !UserType = "GUEST" Then
        strPatron = "018"
        strMessageCode = "a" ' 07-Aug-2003, check address flag
    ElseIf !UserType = "PUBLIC" Then
        strPatron = "003"
        strMessageCode = "a" ' 07-Aug-2003, check address flag
    ElseIf Left(!UserType, 3) = "SWC" Or Left(!UserType, 4) = "UBPX" Then
        strMessageCode = "a"
        strPatron = "010"  ' SWC
        strPCODE1 = "w"    ' SWC
        strDateStatus = Format(!NetExpirationDate, "mm-dd-yy") ' SWC, you know expiration date
    Else
        strPatron = "003"
    End If
   
    ' "Zero" field record.  Need one of these bad boys for each patron (4-11-27 is when I'm 80)
    strRec = strFieldCode & strPatron & strPCODE1 & strPCODE2 & strPCODE3 & _
    conHomeLibrary & strMessageCode & strStatus & strDateStatus
    
    Print #1, strRec
    
    ' u=Institution-assigned ID number
    strRec = "u" & !ID
    Print #1, strRec
    
    ' b=Barcode number (badge+revision)
    strRec = "b" & BadgeNumber(!IDBadge, !IDBadgeRev)
    Print #1, strRec

    ' n=name
    If Len(RTrim(!NameSuffix)) = 0 Then
        strNameTemp = Trim(Nz(!NameLast, ""))
    Else
        strNameTemp = RTrim(Nz(!NameLast, "")) & " " & Trim(Nz(!NameSuffix, ""))
    End If
    strRec = "n" & Left(strNameTemp & ", " & Trim(Nz(!NameFirst, "")) & " " & Trim(Nz(!NameMiddle, "")), 32)
    Print #1, strRec

    ' a=address line 1 and 2, $ seperator (a1 & a2$city & state & zip)
    ' t=telephone
    If Len(Nz(!CampusRoom, "")) > 0 Then ' Assume local if room is specified
        strRec = "a" & !CampusBuilding & !CampusRoom
        Print #1, strRec
        strRec = "t" & !CampusPhone
        Print #1, strRec
    Else
        If Len(Nz(!Address1, "")) > 0 Then
            strRec = "a" & !Address1 & "$" & !City & !State & !Postal
            Print #1, strRec
            strRec = "t" & !Phone
            Print #1, strRec
        End If
    End If
' 07-July-2004 Fix Pass home address & phone plug (for library)
' sample: h802 Dev St.$Cambridge, MA 77721
' sample: p800-222-2222

    ' z=campus email NETEMail
    If Len(Nz(!NETEMail, "")) > 0 Then
        strRec = "z" & !NETEMail
        Print #1, strRec
    End If
           
    !SubSystemUpdate = Now()
    !LastUpdatedInnovative = Now()
    !NeedUpdateInnovative = False
    .Update
    Call DoDataLog("CreateInnovative", "IN", "SUB-USER", "Innovative User", "", strID, strID, bolOnLine)
    .MoveNext
Loop  ' Main loop

End With
Set objRS = Nothing
Close #1 ' Closes data file
dblCount = Kount ' Successfully updated

ExitBegin:
    Call DoEventLog("PRO", strName, 0, "Exit", False, bolOnLine)
    Exit Sub

ErrorBegin:
    If intStatus2 = 0 Then ' General message
        strMessage = "Error in " & strName & " " & Err.Number & " " & Err.Description & " for strID = " & Nz(strID, "")
        intStatus2 = -11 ' I'm NOT OK
    Else
        If strMessage = conNoMessage Then strMessage = "Error = " & Err.Number & " " & Err.Description
    End If
    
    If bolOnLine Then MsgBox strMessage
    bolEmailEventLog = (intStatus2 <> -3)  ' Export file already exists
    Call DoEventLog("ERR", strName, 500, strMessage, bolEmailEventLog, bolOnLine)
    GoTo ExitBegin
End Sub