DESCRIPTION
This script checks an attribute value, it ensures the value will be unique.
Note This code may use functions from the Active Roles Script Policy Best Practices. Please, follow the link to obtain instructions and code for those functions.
SCRIPT
'*********************************************************************************
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
' IF YOU WANT THIS FUNCTIONALITY TO BE CONDITIONALLY SUPPORTED,
' PLEASE CONTACT ONE IDENTITY PROFESSIONAL SERVICES.
'*********************************************************************************
Option Explicit
Dim c_attrName: c_attrName = "initials"
Dim c_class: c_class = "user"
Dim c_filter: c_filter = "(objectClass=user)"
Function CheckUniqueExpression(value)
CheckUniqueExpression = "(&" & c_filter & "(" & c_attrName & "=" & value & "))"
End Function
Function ErrorMessage(value)
ErrorMessage = "The value of the '" & c_attrName & "' property must be unique."
End Function
Sub onCheckPropertyValues(Request)
If Not CheckUnique(Request) Then
Request.SetPolicyComplianceInfo c_attrName, EDS_POLICY_COMPLIANCE_ERROR, _
ErrorMessage(newValue)
End If
End Sub
Sub onPreCreate(Request)
If Not CheckUnique(Request) Then
Err.Raise 450, "CheckUnique", ErrorMessage(newValue)
End If
End Sub
Sub onPreModify(Request)
If Not CheckUnique(Request) Then
Err.Raise 450, "CheckUnique", ErrorMessage(newValue)
End If
End Sub
Function CheckUnique(Request)
CheckUnique = True
If Not (LCase(Request.Class) = LCase(c_class)) Then Exit Function
If Not IsAttributeModified(c_attrName, Request) Then Exit Function
Dim newValue: newValue = GetAttribute(c_attrName, Request)
If IsEmpty(newValue) Then Exit Function
Dim list: list = GetByExpression(CheckUniqueExpression(newValue))
If Count(list) = 0 Then
CheckUnique = True
ElseIf Count(list) = 1 And Request.ADsPath = list(LBound(list)) Then
CheckUnique = True
Else ' Count(list) > 1
CheckUnique = False
End If
End Function
Function GetByExpression(ByVal expression)
Dim command: Set command = GetAdodbCommand("CN=Active Directory", expression, "ADsPath", "subTree")
Dim rs: Set rs = command.Execute
Dim list()
Dim i: i = -1
Do Until rs.EOF Or i > 1
i = i + 1
ReDim Preserve list(i)
list(i) = CStr(rs.Fields("ADsPath").Value)
rs.MoveNext
Loop
GetByExpression = list
Set rs = Nothing
End Function
'------------------------------------------------------------------------------
Function GetAdodbConnection()
Dim adodbConnection: Set adodbConnection = CreateObject("ADODB.Connection")
adodbConnection.Provider = "ADsDSOObject"
adodbConnection.Properties("ADSI Flag") = 32768
adodbConnection.Open "DS Query", "", ""
Set GetAdodbConnection = adodbConnection
Set adodbConnection = Nothing
End Function
Function GetAdodbCommand(ByVal from, ByVal where, ByVal slect, ByVal scope)
Dim command: Set command = CreateObject("ADODB.Command")
command.ActiveConnection = GetAdodbConnection()
command.CommandText = "<EDMS://" & from & ">;" & where & ";" & slect & ";" & scope
Set GetAdodbCommand = command
Set command = Nothing
End Function
Function Count(arr)
Count = 0
On Error Resume Next
Count = UBound(arr) - LBound(arr) + 1
End Function
'------------------------------------------------------------------------------
Function IsAttributeModified (ByVal strAttributeName, ByRef Request)
IsAttributeModified = False
Dim objEntry: Set objEntry = Request.GetPropertyItem(strAttributeName, ADSTYPE_CASE_IGNORE_STRING)
If (objEntry Is Nothing) Then Exit Function
If (objEntry.ControlCode = 0) Then Exit Function
IsAttributeModified = True
End Function
Function GetAttribute (ByVal strAttributeName, ByRef Request)
GetAttribute = Empty
On Error Resume Next
GetAttribute = Request.Get(strAttributeName)
On Error GoTo 0
End Function
'***** END OF CODE ***************************************************************