如何使用iADs,CDO访问W2K Server与Exchange Server 2000.

Question

'*************************************************************************
'*                         JComponents ver 1.0.0.x                       *
'*                 Author:Johnny Lill  Date:2002/11/27                   *
'*                                                                       *
'* References Request: Active DS Type Library;                           *
'*                     Microsoft CDO For Exchange Management Library     *
'*                     Microsoft CDO For Exchange 2000 Library           *
'*************************************************************************Option Explicit
Public Version As String
Public Function DeleteAccount(ByVal strDomainName As String, ByVal strServerFullName As String, ByVal strUserName As String) As Integer
Dim objUser As IADsUser
Dim objMailbox As CDOEXM.IMailboxStore
Dim objContainer As IADsContainer'get user
On Error GoTo ErrHandle_D1
Set objUser = GetObject("LDAP://CN=" + strUserName + ",CN=users," + strDomainName)'get container
On Error GoTo ErrHandle_D2
Set objContainer = GetObject("WinNT://" + strServerFullName + ",computer")'delete mailbox from user
On Error GoTo ErrHandle_D3
Set objMailbox = objUser
objMailbox.DeleteMailbox'delete user from container
On Error GoTo ErrHandle_D4objContainer.Delete "User", strUserName
'all task compeleted
Set objUser = Nothing
Set objContainer = Nothing
Set objMailbox = Nothing
DeleteAccount = 0
Exit Function'user not exist or Domain name error
ErrHandle_D1:
Set objUser = Nothing
Set objContainer = Nothing
Set objMailbox = Nothing
DeleteAccount = 1
Exit Function'full server name or ip address error
ErrHandle_D2:
Set objUser = Nothing
Set objContainer = Nothing
Set objMailbox = Nothing
DeleteAccount = 2
Exit Function'delete mailbox faild
ErrHandle_D3:
Set objUser = Nothing
Set objContainer = Nothing
Set objMailbox = Nothing
DeleteAccount = 3
Exit Function'delete user account faild
ErrHandle_D4:
Set objUser = Nothing
Set objContainer = Nothing
Set objMailbox = Nothing
DeleteAccount = 4
Exit FunctionEnd Function
Public Function ChangePassword(ByVal strUserName As String, ByVal strDomainName As String, ByVal strOldPassword As String, ByVal strNewPassword As String) As Integer
Dim objUser As IADsUser'get user
On Error GoTo ErrHandle_C1
Set objUser = GetObject("LDAP://CN=" + strUserName + ",CN=Users," + strDomainName)objUser.PasswordRequired = True'change password
On Error GoTo ErrHandle_C2
objUser.ChangePassword strOldPassword, strNewPassword'all task compeleted
Set objUser = Nothing
ChangePassword = 0Exit FunctionErrHandle_C1:
'get user error, maybe the user not exist or user's name error
ChangePassword = 1
Set objUser = NothingExit FunctionErrHandle_C2:
'change password error, old password incorrect
ChangePassword = 2
Set objUser = NothingExit FunctionEnd Function

Answer 1

'CreateAccount(1)Public Function CreateAccount(ByVal strDomainName As String, ByVal strLoginName As String, ByVal strFirstName As String, ByVal strLastName As String, ByVal strGroupName As String, ByVal strPassword As String, ByVal strExchangeStore As String, ByVal strExchangeOrg As String, ByVal lngStoreQuota As Long, ByVal lngOverQuotaLimit As Long, ByVal lngHardLimit As Long, ByVal strCreateMailboxLDAP As String, ByVal strServerFullName As String, Optional ByVal strDefaultGroupName As String = "DefaultGroup", Optional ByVal strHeader As String = "crbjl_") As Integer' ==== Parameters reference: =====
'strDomainName:           your domain name, Example: "mydomain.com" is a domain name, the parameter's value is "DC=mydomain,DC=com"
'strLoginName:            your NT logon name, also is your exchange mailbox's logon id
'strFirstName:            first name
'strLastName:             last name
'strGroupName:            group name
'strPassword:             user password
'strExchangeStore:        Exchange Store Name
'strExchangeOrg:          Exchange Server Org Name
'lngStoreQuota:           mailbox 's limit   | Example: this value is 12
'lngOverQuotaLimit:       soft limit         |          this value is 13
'lngHardLimit:            total limit        |          this value is 15    now , this mailbox limit to 15
'strCreateMailboxLDAP:    LDAP url. Example: "LDAP://MainServer.mydomain.com/CN=Mailbox Store (SERVER),CN=First Storage Group,CN=InformationStore,CN=MAINSERVER,CN=Servers,CN=First Administrative Group,CN=Administrative Groups,CN=ExServer,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=mydomain,DC=com"
'strServerFullName:       long server's name. Example: "MainServer.mydomain.com"
'==================================On Error GoTo ErrHandle1
Dim objUser As IADsUser
Dim objContainer As IADsContainer
Dim objMailbox As CDOEXM.IMailboxStore
Dim recipname As String, recip As String
Dim objGroup As Object
Dim Child As Objectrecip = "CN=" & CStr(strLoginName)' get the container
On Error GoTo ErrHandle2
Set objContainer = GetObject("LDAP://" + strServerFullName + "/CN=Users," & _
                             strDomainName)' check the recipient, return error code if it already exist.
For Each Child In objContainer
   If LCase(Right(Child.Name, Len(Child.Name) - 3)) = LCase(strLoginName) Then GoTo ErrHandle3
Next' create a recipient
On Error GoTo ErrHandle4
Set objUser = objContainer.Create("User", recip)
objUser.Put "samAccountName", strLoginName
If Trim(strLastName) <> "" Then
   objUser.Put "sn", strLastName
End If
If Trim(strLastName) <> "" Then
   objUser.Put "givenName", strFirstName
Else
   objUser.Put "givenName", strLoginName
End If
objUser.Put "userPrincipalName", strLoginName
objUser.Put "displayName", CStr(strFirstName) + CStr(strLastName)
objUser.Put "userAccountControl", 66048
objUser.SetInfo
objUser.SetPassword strPassword
objUser.AccountDisabled = False'add recipient to the exist groupIf LCase(strGroupName) = LCase(CStr(CStr(strHeader) & CStr(strDefaultGroupName))) Then
    On Error GoTo ErrHandle51
    Set objGroup = GetObject("LDAP://" + strServerFullName & _
                             "/CN=" + CStr(CStr(strHeader) & _
                             CStr(strDefaultGroupName)) & _
                             ",CN=Users," + strDomainName)
    
    objGroup.Add ("LDAP://" + strServerFullName + "/CN=" & _
                  CStr(strLoginName) + ",CN=Users," + strDomainName)
Else
    On Error GoTo ErrHandle51
    Set objGroup = GetObject("LDAP://" + strServerFullName & _
                             "/CN=" + CStr(CStr(strHeader) & _
                             CStr(strDefaultGroupName)) & _
                             ",CN=Users," + strDomainName)
    
    objGroup.Add ("LDAP://" + strServerFullName + "/CN=" & _
                  CStr(strLoginName) + ",CN=Users," + strDomainName)    On Error GoTo ErrHandle5
    Set objGroup = GetObject("LDAP://" + strServerFullName & _
                             "/CN=" + strGroupName + ",CN=Users," + strDomainName)
    
    objGroup.Add ("LDAP://" + strServerFullName + "/CN=" & _
                  CStr(strLoginName) + ",CN=Users," + strDomainName)
End IfOn Error GoTo ErrHandle6
Set objMailbox = objUser'Create a mailbox for the recipient
'You cannot create a mailbox using ADSI, so use CDOEXMIf Trim(strCreateMailboxLDAP) = "" Then
   objMailbox.CreateMailbox "LDAP://" + strServerFullName & _
                            "/CN=Mailbox Store (" + strExchangeStore & _
                            "),CN=First Storage Group,CN=InformationStore,CN=" & _
                            strExchangeStore + ",CN=Servers,CN=First Administrative Group,CN=Administrative Groups,CN=" & _
                            strExchangeOrg + ",CN=Microsoft Exchange,CN=Services,CN=Configuration," & _
                            strDomainName
Else
   objMailbox.CreateMailbox strCreateMailboxLDAP
End IfobjUser.SetInfo
'Set mailbox limitsOn Error GoTo ErrHandle7
objMailbox.EnableStoreDefaults = False
objMailbox.StoreQuota = lngStoreQuota
objMailbox.OverQuotaLimit = lngOverQuotaLimit
objMailbox.HardLimit = lngHardLimit
objUser.SetInfo

Answer 2

'CreateAccount(2) 这部分和上面要和在一起，这是CreateAccount的错误处理部分'---------- all task compeleted, clean objects
CreateAccount = 0
Set objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle1:
'---------- fatal error, objects can't be create
CreateAccount = 1
Set objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle2:
'---------- full server name error or domain name error
CreateAccount = 2
Set objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle3:
'---------- the account already exist
CreateAccount = 3
Set objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle4:
'----------- create account faild
CreateAccount = 4
Set objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle5:
'---------- add to group faild
CreateAccount = 5'rollback
On Error Resume Next
Set objUser = GetObject("LDAP://CN=" + strLoginName + ",CN=users," + strDomainName)'get container
Set objContainer = GetObject("WinNT://" + strServerFullName + ",computer")'delete mailbox from user
Set objMailbox = objUserIf Trim(objMailbox.HomeMDB) <> "" Then
   objMailbox.DeleteMailbox
End IfobjContainer.Delete "User", strLoginNameSet objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle51:
'---------- add to default group faild
CreateAccount = 51'rollback
On Error Resume Next
Set objUser = GetObject("LDAP://CN=" + strLoginName + ",CN=users," + strDomainName)'get container
Set objContainer = GetObject("WinNT://" + strServerFullName + ",computer")'delete mailbox from user
Set objMailbox = objUserIf Trim(objMailbox.HomeMDB) <> "" Then
   objMailbox.DeleteMailbox
End IfobjContainer.Delete "User", strLoginNameSet objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit Function
ErrHandle6:
'----------- create mailbox faild
CreateAccount = 6'rollback
On Error Resume Next
Set objUser = GetObject("LDAP://CN=" + strLoginName + ",CN=users," + strDomainName)'get container
Set objContainer = GetObject("WinNT://" + strServerFullName + ",computer")'delete mailbox from user
Set objMailbox = objUserIf Trim(objMailbox.HomeMDB) <> "" Then
   objMailbox.DeleteMailbox
End IfobjContainer.Delete "User", strLoginNameSet objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionErrHandle7:
'----------- set mailbox's size limits faild
CreateAccount = 7'rollback
On Error Resume Next
Set objUser = GetObject("LDAP://CN=" + strLoginName + ",CN=users," + strDomainName)'get container
Set objContainer = GetObject("WinNT://" + strServerFullName + ",computer")'delete mailbox from user
Set objMailbox = objUserIf Trim(objMailbox.HomeMDB) <> "" Then
   objMailbox.DeleteMailbox
End IfobjContainer.Delete "User", strLoginNameSet objUser = Nothing
Set objMailbox = Nothing
Set objGroup = Nothing
Set objContainer = Nothing
Exit FunctionEnd Function