Error when creating a custom attribute on SetInfo: The Directory Service is busy.
Hi All
I am creating a custom attribute and I keep getting the error: The directory
service is busy.
Below is the VB6 code.
'--MODULE: mRemoteRegistry
Option Explicit
'<General Constants>
Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_DWORD = 4
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS +
KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY +
READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE +
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK +
READ_CONTROL
Private Const ERROR_NONE = 0
Private Const ERROR_BADKEY = 2
Private Const ERROR_ACCESS_DENIED = 8
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
'</General Constants>
'<Registry Constants>
Public Enum HKEYS
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
End Enum
Public Const REG_KEY_DIGIDATA As String = "SOFTWARE\Read And
Associates\DigiData Enterprise Edition"
Public Const REG_VALUE_VERSIONV5 As String = "VersionV5"
Public Const REG_KEY_ADS_SCHEMA_PARAMETERS As String =
"SYSTEM\CurrentControlSet\Services\NTDS\Parameters"
Public Const REG_VALUE_SCHEMAUPDATEALLOWED As String = "Schema Update
Allowed"
'</Registry Constants>
'<Registry Declarations>
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias
"RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long,
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long)
As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal
Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal
samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef
phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA"
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long,
ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal
lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef
lpcbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal
Reserved As Long, ByVal dwType As Long, ByVal lpData As Long, ByVal cbData
As Long) As Long
'</Registry Declarations>
'<Error Handling>
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Declare Function FormatMessage Lib "kernel32" Alias
"FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId
As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize
As Long, Arguments As Long) As Long
'</Error Handling>
'<Query Remote Registry Function>
'<Query String>
Public Function QueryRemoteRegString(ByVal sComputerName As String,
ByVal hKey As HKEYS, _
ByVal sRegistryKey As String, ByVal
sRegistryValue As String, _
ByRef bResult As Boolean, Optional
ByRef sErrorDescription As String) As String
Dim lRet As Long
Dim lRemoteHandle As Long
Dim lSubRegKeyHandle As Long
Dim sValue As String
Dim lKeyValType As Long
Dim sTmpVal As String
Dim lKeyValSize As Long
Dim i As Long
bResult = False
sTmpVal = String$(1024, 0)
lKeyValSize = 1024
lRet = RegConnectRegistry(sComputerName, hKey, lRemoteHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegOpenKeyEx(lRemoteHandle, sRegistryKey, 0, KEY_READ,
lSubRegKeyHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegQueryValueEx(lSubRegKeyHandle, sRegistryValue, 0, _
lKeyValType, sTmpVal, lKeyValSize)
If lRet = 0 Then
sTmpVal = Left$(sTmpVal, InStr(sTmpVal, Chr(0)) - 1)
sValue = ""
Select Case lKeyValType
Case REG_SZ, REG_EXPAND_SZ
sValue = Trim$(sTmpVal)
Case REG_DWORD
For i = Len(sTmpVal) To 1 Step -1
sValue = sValue + Hex(Asc(Mid(sTmpVal, i, 1)))
Next
sValue = Format$("&h" + sValue)
End Select
bResult = True
sErrorDescription = ""
Else
'<Some Error Opening the key. Assume does not exist. use
FormatMessage with lret>
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lSubRegKeyHandle)
Else
'<Some Error Opening the key. Assume does not exist. use
FormatMessage with lret>
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lRemoteHandle)
Else
'<Could not connect to remote computer>
sErrorDescription = pGetError(lRet)
End If
QueryRemoteRegString = sValue
End Function
'</Query String>
'<Query Long>
'</Query Long>
'<Query Key Exists>
'</Query Key Exists>
'<Query Value Exists>
Public Function QueryRemoteRegValueExists(ByVal sComputerName As String,
ByVal hKey As HKEYS, _
ByVal sRegistryKey As String,
ByVal sRegistryValue As String, _
Optional ByRef
sErrorDescription As String) As Boolean
Dim lRet As Long
Dim lRemoteHandle As Long
Dim lSubRegKeyHandle As Long
Dim sValue As String
Dim lKeyValType As Long
Dim sTmpVal As String
Dim lKeyValSize As Long
Dim i As Long
Dim bResult As Boolean
bResult = False
sTmpVal = String$(1024, 0)
lKeyValSize = 1024
lRet = RegConnectRegistry(sComputerName, hKey, lRemoteHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegOpenKeyEx(lRemoteHandle, sRegistryKey, 0, KEY_READ,
lSubRegKeyHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegQueryValueEx(lSubRegKeyHandle, sRegistryValue, 0, _
lKeyValType, sTmpVal, lKeyValSize)
If lRet = 0 Then
bResult = True
Else
'<Some Error Opening the key. Assume does not exist. use
FormatMessage with lret>
bResult = False
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lSubRegKeyHandle)
Else
'<Some Error Opening the key. Assume does not exist. use
FormatMessage with lret>
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lRemoteHandle)
Else
'<Could not connect to remote computer>
sErrorDescription = pGetError(lRet)
End If
QueryRemoteRegValueExists = bResult
End Function
'</Query Value Exists>
'<Update/Create Value Long>
Public Function UpdateRemoteRegValueLong(ByVal sComputerName As String,
ByVal hKey As HKEYS, _
ByVal sRegistryKey As String,
ByVal sRegistryValue As String, _
ByVal lNewValue As Long,
Optional ByRef sErrorDescription As String) As Boolean
Dim lRet As Long
Dim lRemoteHandle As Long
Dim lSubRegKeyHandle As Long
Dim sValue As String
Dim lKeyValType As Long
Dim sTmpVal As String
Dim lKeyValSize As Long
Dim i As Long
Dim bResult As Boolean
bResult = False
sTmpVal = String$(1024, 0)
lKeyValSize = 1024
lRet = RegConnectRegistry(sComputerName, hKey, lRemoteHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegOpenKeyEx(lRemoteHandle, sRegistryKey, 0, KEY_ALL_ACCESS,
lSubRegKeyHandle)
If lRet = ERROR_SUCCESS Then
lRet = 0
lRet = RegSetValueExLong(lSubRegKeyHandle, sRegistryValue, _
0, REG_DWORD, _
VarPtr(lNewValue), LenB(lNewValue))
If lRet = ERROR_SUCCESS Then
bResult = True
Else
bResult = False
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lSubRegKeyHandle)
Else
'<Some Error Opening the key. Assume does not exist. use
FormatMessage with lret>
sErrorDescription = pGetError(lRet)
End If
Call RegCloseKey(lRemoteHandle)
Else
'<Could not connect to remote computer>
sErrorDescription = pGetError(lRet)
End If
UpdateRemoteRegValueLong = bResult
End Function
'</Update/Create Value Long>
'</Query Remote Registry Function>
Private Function pGetError(ByVal E As Long) As String
Dim s As String, c As Long
Dim sTmp As String
s = String(256, 0)
c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
0&, E, 0&, s, Len(s), ByVal 0&)
If c Then
sTmp = Left$(s, c)
sTmp = Replace(sTmp, Chr(10), "")
sTmp = Replace(sTmp, Chr(13), "")
pGetError = sTmp
End If
End Function
'--FORM: frmMain (add command buttons as appropriate.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest
As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Sub cmdFindSchemaMaster_Click()
Dim oRootX As Object '<Root Object>
Dim sSchema As String '<Schema DN>
Dim oSchema As Object '<Schema Object>
Dim sMaster As String '<Schema Master DN>
Dim oNTDSDSA As Object
Dim sMasterServer As String '<Master Server DN>
Dim oMasterServer As Object '<Master Server Object>
Dim sMasterDNSName As String
Dim bUpdatesOk As Boolean
Dim sMasterSchemaDN As String
Dim oMasterSchema As Object
Dim oNewAttribute As IADs
Dim sError As String
'<Logic>
'--Connect to domain
'--Discover Master Schema Server
'--Connect to Master Schema object
'--For each Attribute
'--Check Attributes exists
'--If not exist, create
'--For each Object
'--Check Object exists
'--If not exist, create
'</Logic>
Err.Clear
On Error Resume Next
Set oRootX = GetObject("LDAP://rootDSE")
If Err.Number = 0 Then
sSchema = oRootX.Get("schemaNamingContext")
If Err.Number = 0 Then
Set oSchema = GetObject("LDAP://" & sSchema)
If Err.Number = 0 Then
sMaster = oSchema.Get("fsmoRoleOwner")
If Err.Number = 0 Then
Set oNTDSDSA = GetObject("LDAP://" & sMaster)
If Err.Number = 0 Then
sMasterServer = oNTDSDSA.Parent
If Err.Number = 0 Then
Set oMasterServer = GetObject(sMasterServer)
If Err.Number = 0 Then
bUpdatesOk = False
sMasterDNSName = oMasterServer.Get("dNSHostName")
If Not QueryRemoteRegValueExists(sMasterDNSName,
HKEY_LOCAL_MACHINE, REG_KEY_ADS_SCHEMA_PARAMETERS,
REG_VALUE_SCHEMAUPDATEALLOWED) Then
MsgBox "Schema Update Allowed does not exist.", vbOKOnly,
"DigiData 2005 Enterprise Edition"
'<Create the key and set to 1>
If UpdateRemoteRegValueLong(sMasterDNSName,
HKEY_LOCAL_MACHINE, REG_KEY_ADS_SCHEMA_PARAMETERS,
REG_VALUE_SCHEMAUPDATEALLOWED, 1) Then
'MsgBox "Updates now enabled"
bUpdatesOk = True
Else
MsgBox "Error enabling updates"
End If
Else
If UpdateRemoteRegValueLong(sMasterDNSName,
HKEY_LOCAL_MACHINE, REG_KEY_ADS_SCHEMA_PARAMETERS,
REG_VALUE_SCHEMAUPDATEALLOWED, 1) Then
'MsgBox "Updates now enabled"
bUpdatesOk = True
Else
MsgBox "Error enabling updates"
End If
End If
If bUpdatesOk Then
sMasterSchemaDN = pBuildMasterSchemaDN(sMasterDNSName)
Set oMasterSchema = GetObject(sMasterSchemaDN)
If Err.Number = 0 Then
'MsgBox "Got Master Schema Object", vbOKOnly, "DigiData
2005 Enterprise Edition"
If pCreateADSchemaAttribute(oMasterSchema,
"raDD-SQLServerIpAddress", _
"raDD-SQLServerIpAddress",
"1.2.840.113556.1.8000.1963.2.1", _
"{E71261B6-8650-4E67-8C98-F5FF846DDDD2}",
"2.5.5.12", _
64, "", _
"I.P. Address or Computer
Name of the SQL Server containing the DigiData Database.", True, _
True, False, _
1, 128, _
0,
"raDD-SQLServerIpAddress", _
oNewAttribute, sError) Then
oNewAttribute.SetInfo
If Err.Number = 0 Then
MsgBox "Attribute Created", vbOKOnly, "DigiData 2005
Enterprise Edition"
Else
MsgBox "Error Creating Attribute: " &
Err.Description & ":" & Err.LastDllError, vbOKOnly, "DigiData 2005
Enterprise Edition"
End If
Else
MsgBox "Error Creating Attribute: " & sError,
vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error getting Master Schema Object: " &
Err.Description, vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Set oMasterSchema = Nothing
End If
Else
MsgBox "Error binding to master server: " & Err.Description,
vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error retrieving Master Server: " & Err.Description,
vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error binding to master schema object: " &
Err.Description, vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error retrieving Schema Master DN: " & Err.Description,
vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error Binding to schema: " & Err.Description, vbOKOnly,
"DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error getting schemaNamingContext: " & Err.Description,
vbOKOnly, "DigiData 2005 Enterprise Edition"
End If
Else
MsgBox "Error binding to rootDSE: " & Err.Description, vbOKOnly,
"DigiData 2005 Enterprise Edition"
End If
Set oMasterSchema = Nothing
Set oMasterServer = Nothing
Set oNTDSDSA = Nothing
Set oSchema = Nothing
Set oRootX = Nothing
End Sub
Private Function pBuildMasterSchemaDN(ByVal sMasterDNSName As String) As
String
Dim sDN As String
Dim lStrPos As Long
Dim sWorking As String
Dim sComponent As String
sDN = "LDAP://" & sMasterDNSName & "/cn=schema,cn=configuration"
'<Remove Computername from DNS>
sWorking = sMasterDNSName
lStrPos = InStr(1, sWorking, ".")
sWorking = Mid$(sWorking, lStrPos + 1)
'</Remove Computername from DNS>
'<for each remaining DNS item add ",dc=xxx">
lStrPos = InStr(1, sWorking, ".")
Do While Not lStrPos = 0
sComponent = Mid$(sWorking, 1, lStrPos - 1)
sWorking = Trim$(Mid$(sWorking, lStrPos + 1))
sDN = sDN & ",dc=" & sComponent
lStrPos = InStr(1, sWorking, ".")
Loop
If LenB(sWorking) <> 0 Then
sDN = sDN & ",dc=" & sWorking
End If
'</for each remaining DNS item add ",dc=xxx">
pBuildMasterSchemaDN = sDN
End Function
'<Create AD Attribute Element>
Private Function pCreateADSchemaAttribute(ByVal oSchemaObject As Object,
ByVal sAttributeName As String, _
ByVal sLDAPDisplayName As
String, ByVal sAttributeOID As String, _
ByVal sAttributeGUID As String,
ByVal sAttributeSyntax As String, _
ByVal lOmAttributeSyntax As
Long, ByVal sOmObjectClass As String, _
ByVal sAttributeDescription As
String, ByVal bIsSingleValued As Boolean, _
ByVal bIsInGC As Boolean, ByVal
bIsIndexed As Boolean, _
ByVal lLowerRange As Long, ByVal
lUpperRange As Long, _
ByVal lLinkId As Long, ByVal
sAdminDisplayName As String, _
ByRef oNewAttribute As IADs,
Optional ByRef sErrorDescription As String) As Boolean
Dim bResult As Boolean
Dim oIADsInterfaceX As IADs
Dim sAttributeToSet As String
Err.Clear
On Error Resume Next
bResult = False
If LenB(Trim$(sAttributeName)) <> 0 And _
LenB(Trim$(sAttributeOID)) <> 0 And _
LenB(Trim$(sAttributeSyntax)) <> 0 And _
lOmAttributeSyntax <> 0 Then
If Not (oSchemaObject Is Nothing) Then
If lLowerRange < lUpperRange Then
Set oNewAttribute = oSchemaObject.Create("attributeSchema", "cn=" &
sAttributeName)
If Err.Number = 0 And _
Not (oNewAttribute Is Nothing) Then
Set oIADsInterfaceX = oNewAttribute
If Err.Number = 0 And _
Not (oIADsInterfaceX Is Nothing) Then
sAttributeToSet = "cn"
Call oIADsInterfaceX.Put(sAttributeToSet, sAttributeName)
If Err.Number = 0 Then
oIADsInterfaceX.Put "cn", sAttributeName
oIADsInterfaceX.Put "lDAPDisplayName", sAttributeName
oIADsInterfaceX.Put "attributeID", sAttributeOID
oIADsInterfaceX.Put "attributeSyntax", sAttributeSyntax
oIADsInterfaceX.Put "oMSyntax", lOmAttributeSyntax
oIADsInterfaceX.Put "isSingleValued", bIsSingleValued
oIADsInterfaceX.Put "adminDescription", sAttributeDescription
oIADsInterfaceX.Put "rangeUpper", lUpperRange
oIADsInterfaceX.Put "rangeLower", lLowerRange
oIADsInterfaceX.Put "schemaIDGUID", sAttributeGUID
bResult = True
Else
'<Error, Setting Attribute cn>
sErrorDescription = "Error, Setting Attribute cn: " &
Err.Description
Set oNewAttribute = Nothing
bResult = False
'</Error, Setting Attribute cn>
End If
Else
'<Error, New Attribute does not have the required interface>
sErrorDescription = "Error, New Attribute does not have the
required interface: " & Err.Description
Set oNewAttribute = Nothing
bResult = False
'</Error, New Attribute does not have the required interface>
End If
Set oIADsInterfaceX = Nothing
Else
'<Error Creating New Attribute Object>
sErrorDescription = "Error Creating New Attribute Object: " &
Err.Description
Set oNewAttribute = Nothing
bResult = False
'</Error Creating New Attribute Object>
End If
Else
'<Ranges invalid>
sErrorDescription = "Ranges invalid"
Set oNewAttribute = Nothing
bResult = False
'</Ranges invalid>
End If
Else
'<Schema Object Invalid>
sErrorDescription = "Schema Object Invalid"
Set oNewAttribute = Nothing
bResult = False
'</Schema Object Invalid>
End If
Else
'<Invalid Mandatory Parameters>
sErrorDescription = "Invalid Mandatory Parameters"
Set oNewAttribute = Nothing
bResult = False
'</Invalid Mandatory Parameters>
End If
Err.Clear
On Error GoTo 0
Bail:
pCreateADSchemaAttribute = bResult
End Function
'</Create AD Attribute Element>
Public Function b2i(ByVal bBool As Boolean) As Integer
If bBool Then
b2i = 1
Else
b2i = 0
End If
End Function
Private Function pToByteArray(ByVal sStringValue As String) As Variant
Dim bArr() As Byte
ReDim bArr(LenB(sStringValue) - 1)
Call CopyMemory(bArr(0), ByVal StrPtr(sStringValue), LenB(sStringValue))
pToByteArray = bArr
End Function
date: Wed, 19 Mar 2008 11:21:44 +0200
author: Brian Vos
