关键是把自己编写的接口和已经存在的接口类关联,嘿嘿!也很简单,只要在注册表里加一项就可以了。(MS想到的方法总是比较容易理解,不过在整体框架那里还是花了很多心思的,所以架子有了扩展就容易了。)例如:以及下就是Exchange加的对User地扩展,它表明Exchange针对User有一个扩展的CoClass--Mailbox,其中包含了两个接口IMailRecipient和IMailboxStore。
"Interfaces"=hex(7):7b,00,32,00,35,00,31,00,35,00,30,00,46,00,34,00,31,00,2d,\
00,35,00,37,00,33,00,34,00,2d,00,31,00,31,00,44,00,32,00,2d,00,41,00,35,00,\
39,00,33,00,2d,00,30,00,30,00,43,00,30,00,34,00,46,00,39,00,39,00,30,00,44,\
00,38,00,41,00,7d,00,00,00,7b,00,32,00,35,00,31,00,35,00,30,00,46,00,34,00,\
30,00,2d,00,35,00,37,00,33,00,34,00,2d,00,31,00,31,00,44,00,32,00,2d,00,41,\
00,35,00,39,00,33,00,2d,00,30,00,30,00,43,00,30,00,34,00,46,00,39,00,39,00,\
30,00,44,00,38,00,41,00,7d,00,00,00,00,00
OID(governsID),LDAP所需要的对象的唯一表示符,这是一个字符串,但是不同于GUID根据本机信息生成,而是逐级分配的属性结构,最上层由ISO分配,逐级授权,所以很麻烦。MS提供了一个工具OIDGEN.exe,随Windows 2000的Resource Kit发布,我不知道即使是用这样的工具生成的新ID能否运行在实际的扩展系统中,还是必须通过MS的认证。
schemaIDGUID,用于访问控制目录中控制访问这个类的对象。通过这个ID而不是名称来访问类的对象实例。GUID还是非常好处理的,可以通过Windows自身的API获得。
其他的就是各类名称(cn,LDAPDisplayName,adminDisplayName),在不同的工具或者场合显示区别类或者属性,这些名字只要保证全局唯一即可。此外classSchema和attributeSchema各有一些特定的必备属性。
新增attributeSchema和classSchema,通过IAdsContainer.Create,在Schema存储的路径下新建子节点,然后给必要的属性赋值,最后提交即可。
禁止attributeSchema和classSchema,可以通过“废弃”的方式禁止一个现存的类或者属性。即获得这个classSchema或者attributeSchema,将他的isDefunct属性置为True即可;反之只要将isDefunct属性置为False即可恢复。当然这个操作也存在一系列的限制,例如:禁止一个属性,那么将阻止创建所有所有必须包含该属性的类的实例。
修改Property与classSchema的关系,因为决定每一个classSchema中包含哪些attributeSchema,其实是指定classSchema的“mustContain”和“mayContain”,这两个多值属性(字符串数组)分别表示表示所包含的必要属性和可选属性。反过来,可以通过IAdsClass.MandantoryProperties和IAdsClass.OptionalProperties读取。
Dim adDomain As IADsContainer
Dim adGroup As IADsGroup
Dim nResult As VBA.Collection
If m_sAdmin <> vbNullString Then
Set adDomain = m_adRoot.OpenDSObject("LDAP://" & m_sExchServer & "/CN=Users," & m_sDomain, _
m_sAdmin, m_sAdminPwd, ADS_SECURE_AUTHENTICATION)
Else
Set adDomain = GetObject("LDAP://CN=Users," & m_sDomain)
End If
If adDomain Is Nothing Then Exit Function
Set nResult = New VBA.Collection
adDomain.Filter = Array("group","user"”)
On Error Resume Next
Dim sName As String
Dim sType As String
For Each adGroup In adDomain
sName = Right(adGroup.Name, Len(adGroup.Name) - 3) ' filter "CN="
Debug.Print sName
sType = adGroup.Get(cPropCustomType)
If Err.Number = 0 And sType = cTypeRC Then
nResult.Add sName, sName
End If
Err.Clear
Next
Set EnumGroups = nResult
End Function
添加用户组和组邮箱的操作类似,不同的是组邮箱不是一个物理邮箱,而是一个邮箱列表,通过IMailRecipient.MailboxEnabled使之有效即可。
Public Function AddAccountEx(ByVal sAccount As String, ByVal sFullName As String, ByVal sDesc As String, _
ByVal sPassword As String) As Long
Dim adDomain As IADsContainer
Dim adNewUser As IADsUser
Dim oMailStore As CDOEXM.IMailboxStore
Dim oExchServer As CExchageManager
If m_sAdmin <> vbNullString Then
Set adDomain = m_adRoot.OpenDSObject("LDAP://CN=Users," & m_sDomain, _
m_sAdmin, m_sAdminPwd, ADS_SECURE_AUTHENTICATION)
Else
Set adDomain = GetObject("LDAP://CN=Users," & m_sDomain)
End If
Set adNewUser = adDomain.Create("user", "cn=" & sAccount)
adNewUser.Put "sAMAccountName", sAccount
adNewUser.Put "userPrincipalName", sAccount & "@" & Domain
adNewUser.FullName = sFullName
adNewUser.Description = sDesc
adNewUser.SetInfo
adNewUser.AccountDisabled = False
' create mailbox for this account
Set oExchServer = New CExchageManager
oExchServer.Connect m_sExchServer ' Get Exchange Server's Information
Set oMailStore = adNewUser
Call oMailStore.CreateMailbox("LDAP://" & m_sExchServer & "/" & oExchServer.DefaultMailboxStore)
adNewUser.SetInfo
adNewUser.Put "msExchUserAccountControl", 2
adNewUser.SetInfo
End Function
这个例子是查询所有指定域中所有的组,其中description就是一个多值属性。
Dim oResult As ADODB.Recordset
Dim oCommand As ADODB.Command
Dim sConnectionStr As String
If m_sAdmin = vbNullString Then
sConnectionStr = "Provider=ADsDSOObject"
Else
sConnectionStr = "Provider=ADsDSOObject;UID=" & m_sAdmin & ";PWD=" & m_sAdminPwd
End If
Set oCommand = New ADODB.Command
With oCommand
.ActiveConnection = sConnectionStr
.CommandTimeout = 15
.CommandText = "SELECT name,description FROM 'LDAP://" & m_sDomain _
& "' WHERE objectCategory='group'"
Debug.Print .CommandText
.Properties("searchscope") = ADS_SCOPE_SUBTREE
.Properties("Chase referrals") = ADS_CHASE_REFERRALS_EXTERNAL
Set oResult = .Execute
End With
If Not oResult Is Nothing Then
Do Until oResult.EOF
Debug.Print oResult("name"), oResult("description")(0)
oResult.MoveNext
Loop
End If
End Function
