基于ADSI的NT帳號及ExchangeServer帳號申請及驗證模塊源代碼

基于ADSI的NT帳號及Exchange Server帳號申請及驗證模塊源代碼

1.安裝ADSI2.5
2.創建一個新的ActiveX DLL工程,工程名:RbsBoxGen,類名:NTUserManager
3.執行工程-引用將下列庫選上:
  Active DS Type Library 
  Microsoft Active Server Pages Object Library 
4.添加一個模塊,代碼如下:
'模塊
'''''''''''''''''''''''''''''''''''''''
'
' ADSI Sample to create and delete Exchange 5.5 Mailboxes
'
' Richard Ault, Jean-Philippe Balivet, Neil Wemple -- 1998
'
'''''''''''''''''''''''''''''''''''''''
Option Explicit

' Mailbox property settings
Public Const LOGON_CMD = "logon.cmd"
Public Const INCOMING_MESSAGE_LIMIT = 1000
Public Const OUTGOING_MESSAGE_LIMIT = 1000
Public Const WARNING_STORAGE_LIMIT = 8000
Public Const SEND_STORAGE_LIMIT = 12000
Public Const REPLICATION_SENSITIVITY = 20
Public Const COUNTRY = "US"

' Mailbox rights for Exchange security descriptor (home made)
Public Const RIGHT_MODIFY_USER_ATTRIBUTES = &H2
Public Const RIGHT_MODIFY_ADMIN_ATTRIBUTES = &H4
Public Const RIGHT_SEND_AS = &H8
Public Const RIGHT_MAILBOX_OWNER = &H10
Public Const RIGHT_MODIFY_PERMISSIONS = &H80
Public Const RIGHT_SEARCH = &H100

' win32 constants for security descriptors (from VB5 API viewer)
Public Const ACL_REVISION = (2)
Public Const SECURITY_DESCRIPTOR_REVISION = (1)
Public Const SidTypeUser = 1

Type ACL
        AclRevision As Byte
        Sbz1 As Byte
        AclSize As Integer
        AceCount As Integer
        Sbz2 As Integer
End Type

Type ACE_HEADER
        AceType As Byte
        AceFlags As Byte
        AceSize As Long
End Type

Type ACCESS_ALLOWED_ACE
        Header As ACE_HEADER
        Mask As Long
        SidStart As Long
End Type

Type SECURITY_DESCRIPTOR
        Revision As Byte
        Sbz1 As Byte
        Control As Long
        Owner As Long
        Group As Long
        Sacl As ACL
        Dacl As ACL
End Type

' Just an help to allocate the 2dim dynamic array
Private Type mySID
    x() As Byte
End Type


' Declares : modified from VB5 API viewer
Declare Function InitializeSecurityDescriptor Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
        ByVal dwRevision As Long) As Long

Declare Function SetSecurityDescriptorOwner Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
        pOwner As Byte, _
        ByVal bOwnerDefaulted As Long) As Long

Declare Function SetSecurityDescriptorGroup Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
        pGroup As Byte, _
        ByVal bGroupDefaulted As Long) As Long

Declare Function SetSecurityDescriptorDacl Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
        ByVal bDaclPresent As Long, _
        pDacl As Byte, _
        ByVal bDaclDefaulted As Long) As Long

Declare Function SetSecurityDescriptorSacl Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
        ByVal bSaclPresent As Long, _
        pSacl As Byte, _
        ByVal bSaclDefaulted As Long) As Long

Declare Function MakeSelfRelativeSD Lib "advapi32.dll" _
        (pAbsoluteSecurityDescriptor As SECURITY_DESCRIPTOR, _
        pSelfRelativeSecurityDescriptor As Byte, _
        ByRef lpdwBufferLength As Long) As Long

Declare Function GetSecurityDescriptorLength Lib "advapi32.dll" _
        (pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long

Declare Function IsValidSecurityDescriptor Lib "advapi32.dll" _
        (pSecurityDescriptor As Byte) As Long

Declare Function InitializeAcl Lib "advapi32.dll" _
        (pACL As Byte, _
        ByVal nAclLength As Long, _
        ByVal dwAclRevision As Long) As Long

Declare Function AddAccessAllowedAce Lib "advapi32.dll" _
        (pACL As Byte, _
        ByVal dwAceRevision As Long, _
        ByVal AccessMask As Long, _
        pSid As Byte) As Long

Declare Function IsValidAcl Lib "advapi32.dll" _
        (pACL As Byte) As Long

Declare Function GetLastError Lib "kernel32" _
        () As Long

Declare Function LookupAccountName Lib "advapi32.dll" _
        Alias "LookupAccountNameA" _
        (ByVal IpSystemName As String, _
        ByVal IpAccountName As String, _
        pSid As Byte, _
        cbSid As Long, _
        ByVal ReferencedDomainName As String, _
        cbReferencedDomainName As Long, _
        peUse As Integer) As Long

Declare Function NetGetDCName Lib "NETAPI32.DLL" _
        (ServerName As Byte, _
        DomainName As Byte, _
        DCNPtr As Long) As Long
                                       
Declare Function NetApiBufferFree Lib "NETAPI32.DLL" _
        (ByVal Ptr As Long) As Long
       
Declare Function PtrToStr Lib "kernel32" _
        Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long

Declare Function GetLengthSid Lib "advapi32.dll" _
        (pSid As Byte) As Long


'''''''''''''''''''''''''''''''''''''''
'
' Create_NT_Account() -- creates an NT user account
'
'''''''''''''''''''''''''''''''''''''''
Public Function Create_NT_Account(strDomain As String, _
                                  strAdmin As String, _
                                  strPassword As String, _
                                  UserName As String, _
                                  FullName As String, _
                                  NTServer As String, _
                                  strPwd As String, _
                                  strRealName As String) As Boolean

Dim oNS As IADsOpenDSObject
Dim User As IADsUser
Dim Domain As IADsDomain

    On Error GoTo Create_NT_Account_Error

    Create_NT_Account = False
   
    If (strPassword = "") Then
        strPassword = ""
    End If
   
    Set oNS = GetObject("WinNT:")
    Set Domain = oNS.OpenDSObject("WinNT://" & strDomain, strDomain & "\" & strAdmin, strPassword, 0)
   
    Set User = Domain.Create("User", UserName)
    With User
        .Description = "ADSI 創建的用戶"
        .FullName = strRealName 'FullName
        '.HomeDirectory = "\\" & NTServer & "\" & UserName
        '.LoginScript = LOGON_CMD
        .SetInfo
        ' First password = username
        .SetPassword strPwd
    End With
   
    Debug.Print "Successfully created NT Account for user " & UserName
    Create_NT_Account = True
    Exit Function

Create_NT_Account_Error:
    Create_NT_Account = False
    Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred creating NT account for user " & UserName

End Function

'''''''''''''''''''''''''''''''''''''''
'
' Delete_NT_Account() -- deletes an NT user account
'
'''''''''''''''''''''''''''''''''''''''
Public Function Delete_NT_Account(strDomain As String, _
                                  strAdmin As String, _
                                  strPassword As String, _
                                  UserName As String _
                                  ) As Boolean

Dim Domain As IADsDomain
Dim oNS As IADsOpenDSObject

    On Error GoTo Delete_NT_Account_Error
   
    Delete_NT_Account = False
   
    If (strPassword = "") Then
        strPassword = ""
    End If

    Set oNS = GetObject("WinNT:")
    Set Domain = oNS.OpenDSObject("WinNT://" & strDomain, strDomain & "\" & strAdmin, strPassword, 0)
   
    Domain.Delete "User", UserName
   
    Debug.Print "Successfully deleted NT Account for user " & UserName
    Delete_NT_Account = True
    Exit Function
   
Delete_NT_Account_Error:
   
    Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred deleting NT account for user " & UserName
   
End Function

'''''''''''''''''''''''''''''''''''''''
'
' Create_Exchange_Mailbox() -- creates an Exchange mailbox, sets mailbox
'                          properties and and associates the mailbox with
'                          an existing NT user account
'
'''''''''''''''''''''''''''''''''''''''
Public Function Create_Exchange_MailBox( _
    IsRemote As Boolean, _
    strServer As String, _
    strDomain As String, _
    strAdmin As String, _
    strPassword As String, _
    UserName As String, _
    EmailAddress As String, _
    strFirstName As String, _
    strLastName As String, _
    ExchangeServer As String, _
    ExchangeSite As String, _
    ExchangeOrganization As String, _
    strPwd As String, _
    strRealName As String) As Boolean


Dim Container As IADsContainer
Dim strRecipContainer As String
Dim Mailbox As IADs
Dim rbSID(1024) As Byte
Dim OtherMailBox() As Variant
Dim sSelfSD() As Byte
Dim encodedSD() As Byte
Dim I As Integer

Dim oNS As IADsOpenDSObject

    On Error GoTo Create_Exchange_MailBox_Error
   
    Create_Exchange_MailBox = False
   
    If (strPassword = "") Then
        strPassword = ""
    End If

    ' Recipients container for this server
    strRecipContainer = "LDAP://" & ExchangeServer & _
                        "/CN=Recipients,OU=" & ExchangeSite & _
                        ",O=" & ExchangeOrganization
    Set oNS = GetObject("LDAP:")
    Set Container = oNS.OpenDSObject(strRecipContainer, "cn=" & strAdmin & ",dc=" & strDomain, strPassword, 0)
   
    ' This creates both mailboxes or remote dir entries
    If IsRemote Then
        Set Mailbox = Container.Create("Remote-Address", "CN=" & UserName)
        Mailbox.Put "Target-Address", EmailAddress
    Else
        Set Mailbox = Container.Create("OrganizationalPerson", "CN=" & UserName) '
        Mailbox.Put "MailPreferenceOption", 0
    End If
   
    With Mailbox
        .SetInfo
       
        ' As an example two other addresses
        ReDim OtherMailBox(1)
        OtherMailBox(0) = "MS$" & ExchangeOrganization & _
                          "/" & ExchangeSite & _
                          "/" & UserName
       
        OtherMailBox(1) = "CCMAIL$" & UserName & _
                          " at " & ExchangeSite
                         
        If Not (IsRemote) Then
            ' Get the SID of the previously created NT user
            Get_Exchange_Sid strDomain, UserName, rbSID
            .Put "Assoc-NT-Account", rbSID
            ' This line also initialize the "Home Server" parameter of the Exchange admin
            .Put "Home-MTA", "cn=Microsoft MTA,cn=" & ExchangeServer & ",cn=Servers,cn=Configuration,ou=" & ExchangeSite & ", o = " & ExchangeOrganization
            .Put "Home-MDB", "cn=Microsoft Private MDB,cn=" & ExchangeServer & ",cn=Servers,cn=Configuration,ou=" & ExchangeSite & ",o=" & ExchangeOrganization
            .Put "Submission-Cont-Length", OUTGOING_MESSAGE_LIMIT
            .Put "MDB-Use-Defaults", False
            .Put "MDB-Storage-Quota", WARNING_STORAGE_LIMIT
            .Put "MDB-Over-Quota-Limit", SEND_STORAGE_LIMIT
            .Put "MAPI-Recipient", True
           
            ' Security descriptor
            ' The rights choosen make a normal user role
            ' The other user is optionnal, delegate for ex.
           
            Call MakeSelfSD(sSelfSD, _
                            strServer, _
                            strDomain, _
                            UserName, _
                            UserName, _
                            RIGHT_MAILBOX_OWNER + RIGHT_SEND_AS + _
                            RIGHT_MODIFY_USER_ATTRIBUTES _
                          )

            ReDim encodedSD(2 * UBound(sSelfSD) + 1)
            For I = 0 To UBound(sSelfSD) - 1
                encodedSD(2 * I) = AscB(Hex$(sSelfSD(I) \ &H10))
                encodedSD(2 * I + 1) = AscB(Hex$(sSelfSD(I) Mod &H10))
            Next I
           
            .Put "NT-Security-Descriptor", encodedSD
        Else
           
            ReDim Preserve OtherMailBox(2)
            OtherMailBox(2) = EmailAddress
            .Put "MAPI-Recipient", False
        End If
       
        ' Usng PutEx for array properties
        .PutEx ADS_PROPERTY_UPDATE, "otherMailBox", OtherMailBox
       
        .Put "Deliv-Cont-Length", INCOMING_MESSAGE_LIMIT
        ' i : initials
        .Put "TextEncodedORaddress", "c=" & COUNTRY & _
                                    ";a= " & _
                                    ";p=" & ExchangeOrganization & _
                                    ";o=" & ExchangeSite & _
                                    ";s=" & strLastName & _
                                    ";g=" & strFirstName & _
                                    ";i=" & Mid(strFirstName, 1, 1) & Mid(strLastName, 1, 1) & ";"
       
        .Put "rfc822MailBox", UserName & "@" & ExchangeSite & "." & ExchangeOrganization & ".com"
        .Put "Replication-Sensitivity", REPLICATION_SENSITIVITY
        .Put "uid", UserName
        .Put "name", UserName

      '  .Put "GivenName", strFirstName
      '  .Put "Sn", strLastName
        .Put "Cn", strRealName 'strFirstName & " " & UserName 'strLastName
      '  .Put "Initials", Mid(strFirstName, 1, 1) & Mid(strLastName, 1, 1)
       
        ' Any of these fields are simply descriptive and optional, not included in
        ' this sample and there are many other fields in the mailbox
        .Put "Mail", EmailAddress
        'If 0 < Len(Direction) Then .Put "Department", Direction
        'If 0 < Len(FaxNumber) Then .Put "FacsimileTelephoneNumber", FaxNumber
        'If 0 < Len(City) Then .Put "l", City
        'If 0 < Len(Address) Then .Put "PostalAddress", Address
        'If 0 < Len(PostalCode) Then .Put "PostalCode", PostalCode
        'If 0 < Len(Banque) Then .Put "Company", Banque
        'If 0 < Len(PhoneNumber) Then .Put "TelephoneNumber", PhoneNumber
        'If 0 < Len(Title) Then .Put "Title", Title
        'If 0 < Len(AP1) Then .Put "Extension-Attribute-1", AP1
        'If 0 < Len(Manager) Then .Put "Extension-Attribute-2", Manager
        'If 0 < Len(Agence) Then .Put "Extension-Attribute-3", Agence
        'If 0 < Len(Groupe) Then .Put "Extension-Attribute-4", Groupe
        'If 0 < Len(Secteur) Then .Put "Extension-Attribute-5", Secteur
        'If 0 < Len(Region) Then .Put "Extension-Attribute-6", Region
        'If 0 < Len(GroupeBanque) Then .Put "Extension-Attribute-7", GroupeBanque
        'If 0 < Len(AP7) Then .Put "Extension-Attribute-8", AP7
        'If 0 < Len(AP8) Then .Put "Extension-Attribute-9", AP8
        .SetInfo
    End With
   
    Debug.Print "Successfully created mailbox for user " & UserName
    Create_Exchange_MailBox = True
    Exit Function

Create_Exchange_MailBox_Error:
    Create_Exchange_MailBox = False
    Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred creating Mailbox for user " & UserName
   
End Function

'''''''''''''''''''''''''''''''''''''''
'
' Delete_Exchange_Mailbox() -- deletes an Exchange mailbox
'
'''''''''''''''''''''''''''''''''''''''
Public Function Delete_Exchange_Mailbox( _
    IsRemote As Boolean, _
    strDomain As String, _
    strAdmin As String, _
    strPassword As String, _
    UserName As String, _
    ExchangeServer As String, _
    ExchangeSite As String, _
    ExchangeOrganization As String _
  ) As Boolean

Dim strRecipContainer As String
Dim Container As IADsContainer
Dim oNS As IADsOpenDSObject

    If (strPassword = "") Then
        strPassword = ""
    End If

    On Error GoTo Delete_Exchange_MailBox_Error
    Delete_Exchange_Mailbox = False
   
    ' Recipients container for this server
    strRecipContainer = "LDAP://" & ExchangeServer & _
                        "/CN=Recipients,OU=" & ExchangeSite & _
                        ",O=" & ExchangeOrganization
    Set oNS = GetObject("LDAP:")
    Set Container = oNS.OpenDSObject(strRecipContainer, "cn=" & strAdmin & ",dc=" & strDomain, strPassword, 0)

    If Not (IsRemote) Then
        Container.Delete "OrganizationalPerson", "CN=" & UserName
    Else
        Container.Delete "Remote-Address", "CN=" & UserName
    End If
   
    Container.SetInfo
   
    Debug.Print "Successfully deleted mailbox for user " & UserName
    Delete_Exchange_Mailbox = True
    Exit Function

Delete_Exchange_MailBox_Error:
   
    Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred deleting Mailbox for user " & UserName

End Function

'''''''''''''''''''''''''''''''''''''''
'
' MakeSelfSD -- builds a self-relative Security Descriptor suitable for ADSI
'
' Return code : 1 = OK
'              0 = error
' In    sSelfSD    dynamic byte array, size 0
'      sServer    DC for the domain
'      sDomain    Domain name
'      sAssocUser  Primary NT account for the mail box (SD owner)
'      paramarray  Authorized accounts
'                  This is an array of (userid, role, userid, role...)
'                  where role is a combination of rights (cf RIGHTxxx constants)
' Out  sSelfSD    Self relative SD allocated and initalized
'
'''''''''''''''''''''''''''''''''''''''
Public Function MakeSelfSD(sSelfSD() As Byte, _
        sServer As String, sDomain As String, _
        sAssocUSer As String, _
        ParamArray ACEList() As Variant) As Long
Dim SecDesc As SECURITY_DESCRIPTOR
Dim I As Integer
Dim tACL As ACL
Dim tACCESS_ALLOWED_ACE As ACCESS_ALLOWED_ACE
Dim pSid() As Byte
Dim pACL() As Byte
Dim pACESID() As mySID
Dim Longueur As Long
Dim rc As Long
   
    On Error GoTo SDError
    ' Initializing abolute SD
    rc = InitializeSecurityDescriptor(SecDesc, SECURITY_DESCRIPTOR_REVISION)
    If (rc <> 1) Then
        Err.Raise -12, , "InitializeSecurityDescriptor"
    End If
   
    rc = GetSID(sServer, sDomain, sAssocUSer, pSid)
    If (rc <> 1) Then
        Err.Raise -12, , "GetSID"
    End If
   
    rc = SetSecurityDescriptorOwner(SecDesc, pSid(0), 0)
    If (rc <> 1) Then
        Err.Raise -12, , "SetSecurityDescriptorOwner"
    End If
   
    ' I don't know why we had to do this one, but it works for us
    rc = SetSecurityDescriptorGroup(SecDesc, pSid(0), 0)
    If (rc <> 1) Then
        Err.Raise -12, , "SetSecurityDescriptorGroup"
    End If
   
    ' Getting SIDs for all the other users, and computing of total ACL length
    ' (famous formula from MSDN)
    Longueur = Len(tACL)
    ReDim Preserve pACESID((UBound(ACEList) - 1) / 2)
    For I = 0 To UBound(pACESID)
        If 1 <> GetSID(sServer, sDomain, CStr(ACEList(2 * I)), pACESID(I).x) Then Err.Raise -12, , "GetSID"
        Longueur = Longueur + GetLengthSid(pACESID(I).x(0)) + Len(tACCESS_ALLOWED_ACE) - 4
    Next I
   
    ' Initalizing ACL, and adding one ACE for each user
    ReDim pACL(Longueur)
    If 1 <> InitializeAcl(pACL(0), Longueur, ACL_REVISION) Then Err.Raise -12, , "InitializeAcl"
    For I = 0 To UBound(pACESID)
        If 1 <> AddAccessAllowedAce(pACL(0), ACL_REVISION, CLng(ACEList(2 * I + 1)), pACESID(I).x(0)) Then Err.Raise -12, , "AddAccessAllowedAce"
    Next I
    If 1 <> SetSecurityDescriptorDacl(SecDesc, 1, pACL(0), 0) Then Err.Raise -12, , "SetSecurityDescriptorDacl"
   
    ' Allocation and conversion in the self relative SD
    Longueur = GetSecurityDescriptorLength(SecDesc)
    ReDim sSelfSD(Longueur)
    If 1 <> MakeSelfRelativeSD(SecDesc, sSelfSD(0), Longueur) Then Err.Raise -12, , "MakeSelfRelativeSD"
    MakeSelfSD = 1
    Exit Function

SDError:
    MakeSelfSD = 0
End Function

'''''''''''''''''''''''''''''''''''''''
'
' GetSID -- gets the Security IDentifier for the specified account name
'
'''''''''''''''''''''''''''''''''''''''
Public Function GetSID(sServer As String, sDomain As String, sUserID As String, pSid() As Byte) As Long
Dim rc As Long
Dim pDomain() As Byte
Dim lSID As Long, lDomain As Long
Dim sSystem As String, sAccount As String

    On Error GoTo SIDError
   
    ReDim pSid(0)
    ReDim pDomain(0)
    lSID = 0
    lDomain = 0
    sSystem = "\\" & sServer
    sAccount = sDomain & "\" & sUserID
   
    rc = LookupAccountName(sSystem, sAccount, pSid(0), lSID, pDomain(0), lDomain, SidTypeUser)
   
    If (rc = 0) Then
        ReDim pSid(lSID)
        ReDim pDomain(lDomain + 1)

        rc = LookupAccountName(sSystem, sAccount, pSid(0), lSID, pDomain(0), lDomain, SidTypeUser)
        If (rc = 0) Then
            GoTo SIDError
        End If
    End If
   
    GetSID = 1
    Exit Function

SIDError:
    GetSID = 0
End Function

'''''''''''''''''''''''''''''''''''''''
'
' Get_Primary_DCName -- gets the name of the Primary Domain Controller for
'                      the NT domain
'
'''''''''''''''''''''''''''''''''''''''
Function Get_Primary_DCName(ByVal MName As String, ByVal DName As String) As String

Dim Result As Long
Dim DCName As String
Dim DCNPtr As Long
Dim DNArray() As Byte
Dim MNArray() As Byte
Dim DCNArray(100) As Byte

    MNArray = MName & vbNullChar
    DNArray = DName & vbNullChar
    Result = NetGetDCName(MNArray(0), DNArray(0), DCNPtr)
    If Result <> 0 Then
        Exit Function
    End If
    Result = PtrToStr(DCNArray(0), DCNPtr)
    Result = NetApiBufferFree(DCNPtr)
    DCName = DCNArray()
    Get_Primary_DCName = DCName
   
End Function

'''''''''''''''''''''''''''''''''''''''
'
' Get_Exchange_Sid -- gets the NT user's Security IDentifier for Exchange
'
'''''''''''''''''''''''''''''''''''''''
Sub Get_Exchange_Sid(strNTDomain As String, strNTAccount As String, rbSID() As Byte)

Dim pSid(512) As Byte
Dim pDomain(512) As Byte
Dim IReturn As Long
Dim I As Integer
Dim NtDomain As String
NtDomain = strNTDomain
    IReturn = LookupAccountName(Get_Primary_DCName("", NtDomain), strNTAccount, pSid(0), 512, pDomain, 512, 1)
   
    For I = 0 To GetLengthSid(pSid(0)) - 1
        rbSID(2 * I) = AscB(Hex$(pSid(I) \ &H10))
        rbSID(2 * I + 1) = AscB(Hex$(pSid(I) Mod &H10))
    Next I
End Sub

5.將下列代碼粘貼到NTUserManager類模塊,注意修改默認屬性
'類名:NTUserManager
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'              DECLARE VARIABLES
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Private MyScriptingContext As ScriptingContext
    Private MyRequest As Request
    Private MyResponse As Response
    Private MyServer As Server
  Dim txtDomain As String, txtAdmin As String
  Dim txtPassword As String, txtUserName As String
  Dim txtFirstName As String, txtLastName As String
  Dim txtNTServer As String
  Dim txtEMailAddress As String, txtExchServer As String
  Dim txtExchSite As String, txtExchOrganization As String
  Dim txtPwd As String, txtRealName As String
  Dim bIsOk As Boolean
   
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'                OnStartPage
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub OnStartPage(PassedScriptingContext As ScriptingContext)

    Set MyScriptingContext = PassedScriptingContext
    Set MyRequest = MyScriptingContext.Request
    Set MyResponse = MyScriptingContext.Response
    Set MyServer = MyScriptingContext.Server
End Sub
Public Sub GetUserInfo()

    '~~~~~~~~~~~~~~~~~~ ERROR CODE ~~~~~~~~~~~~~~~~
'  On Error GoTo ErrorCode
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
txtUserName = MyRequest.Form("UID")
txtPwd = MyRequest.Form("PWD")
txtRealName = MyRequest.Form("Name")
End Sub
Public Sub DeleteUser()
    Call Delete_Exchange_Mailbox(False, txtDomain, txtAdmin, _
                                txtPassword, txtUserName, txtExchServer, _
                                txtExchSite, txtExchOrganization)
    Call Delete_NT_Account(txtDomain, txtAdmin, txtPassword, txtUserName)
End Sub

Public Sub CreateUser()
    bIsOk = Create_NT_Account(txtDomain, txtAdmin, txtPassword, _
                          txtUserName, txtFirstName & txtLastName, _
                          txtNTServer, txtPwd, txtRealName)
                           
    If Not bIsOk Then Exit Sub
    bIsOk = Create_Exchange_MailBox(False, txtNTServer, txtDomain, txtAdmin, _
                                txtPassword, txtUserName, txtEMailAddress, _
                                txtFirstName, txtLastName, txtExchServer, _
                                txtExchSite, txtExchOrganization, txtPwd, txtRealName)
    If Not bIsOk Then Exit Sub
End Sub
Public Property Let Domain(ByVal vNewValue As Variant)
txtDomain = vNewValue
End Property

Public Property Let Admin(ByVal vNewValue As Variant)
txtAdmin = vNewValue
End Property

Public Property Let Password(ByVal vNewValue As Variant)
txtPassword = vNewValue
End Property

Public Property Let NTServer(ByVal vNewValue As Variant)
txtNTServer = vNewValue
End Property
Public Property Let EmailAddress(ByVal vNewValue As Variant)
txtEMailAddress = vNewValue
End Property

Public Property Let ExchServer(ByVal vNewValue As Variant)
txtExchServer = vNewValue
End Property

Public Property Let ExchSite(ByVal vNewValue As Variant)
txtExchSite = vNewValue
End Property

Public Property Let ExchOrganization(ByVal vNewValue As Variant)
txtExchOrganization = vNewValue
End Property
Private Sub Class_Initialize()
  txtDomain = "XX"  '此處該為主域名
  txtAdmin = "administrator"  '超級管理員帳號
  txtPassword = ""            '超級管理員密碼
  txtNTServer = "XXserver"    '主域控制器主機名
  txtEMailAddress = "@sina.net" '郵件服務器域名
  txtExchServer = "XXserver"  'Exchange服務器的主機名
  txtExchSite = "XX"          'Exchange站點名稱
  txtExchOrganization = "xxx"  'Exchange組織名稱
  bIsOk = True
End Sub
Public Property Get IsOK() As Variant
IsOK = bIsOk
End Property

Public Sub ChangePwd(ByVal UID As String, ByVal oPwd As String, ByVal nPwd As String)
Dim o As IADsOpenDSObject
Dim usr As IADsUser

On Error GoTo ErrMsg

Set o = GetObject("WinNT:")
Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID, UID, oPwd, 1)
usr.ChangePassword oPwd, nPwd
bIsOk = True
Exit Sub

ErrMsg:
bIsOk = False
End Sub

Public Sub ResetPwd(ByVal UID As String, ByVal nPwd As String)
Dim o As IADsOpenDSObject
Dim usr As IADsUser

On Error GoTo ErrMsg

Set o = GetObject("WinNT:")
Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID & ",user", txtAdmin, txtPassword, 1)


usr.SetPassword nPwd
bIsOk = True
Exit Sub

ErrMsg:
bIsOk = False

End Sub
Public Sub Login(ByVal UID As String, ByVal Pwd As String)
Dim o As IADsOpenDSObject
Dim usr As IADsUser
Dim nPwd As String
On Error GoTo ErrMsg

Set o = GetObject("WinNT:")
Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID & ",user", txtAdmin, txtPassword, 1)

nPwd = Pwd & "X"

usr.ChangePassword Pwd, nPwd
usr.SetPassword Pwd
bIsOk = True

Exit Sub

ErrMsg:
bIsOk = False

End Sub

6.編譯工程
7.注冊RbsBoxGen.dll或在Mts中注冊

注:本單位主域控制器與Exchange服務器及WEB服務器為同一機器.

附:ASB示例
1申請郵箱
a>申請頁面:UserAdd.htm
<html>

<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<meta name="GENERATOR" content="Microsoft FrontPage 4.0">
<meta name="ProgId" content="FrontPage.Editor.Document">
<title>New Page 1</title>
<meta name="Microsoft Theme" content="mstheme1530 1111, default">
</head>

<body>

<form method="POST" action="UserAdd.asp" onsubmit="return FrontPage_Form1_Validator(this)" name="FrontPage_Form1">
  <p>帳號<input type="text" name="UID" size="20"></p>
  <p>密碼<input type="text" name="PWD" size="20"></p>
  <p>姓名<input type="text" name="Name" size="20"><input type="submit" value="提交" name="B1"><input type="reset" value="全部重寫" name="B2"></p>
</form>

</body>

</html>

b>響應文件UserAdd.asp
<HTML>
<head>
<meta name="Microsoft Theme" content="mstheme1530 1111, default">
</head>
<BODY>
<H1>　</H1>
<%
 
  '  Variables
dim rbox
set rbox = Server.CreateObject("RbsBoxGen.NTUserManager")
'以下如果已在DLL的初始化事件中設置正確則無須設置,可提高安全性
'rbox.Domain="yourdomain"
'rbox.Admin="administrator"
'rbox.password="XXXXXX"
'rbox.Ntserver="yonrntserver"
'rbox.EmailAddress="@Xxx.xxx"
'rbox.ExchServer="yourExchangeServerName"
'rbox.ExchSite="yourExchangeSiteName"
'rbox.ExchOrganization="yourExchangeOrganizationName"
  rbox.getuserinfo
   
  rbox.CreateUser 
  'rbox.DeleteUser 

  if rbox.isok then
  set rbox = nothing
  response.write "注冊成功!"
  else
  set rbox = nothing
  response.write "該用戶名已被使用，請換一個名字再試！"
  end if
 

%>
</BODY>
</HTML>

2修改密碼:
a>.密碼修改頁面CHPWD.htm
<html>

<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<meta name="GENERATOR" content="Microsoft FrontPage 4.0">
<meta name="ProgId" content="FrontPage.Editor.Document">
<title>New Page 1</title>
<SCRIPT LANGUAGE="VBScript">
<!--
Sub cmdOk_OnClick
Dim TheForm
Set TheForm = Document.MyForm

opwd=trim(TheForm.opwd.Value)
npwd=trim(TheForm.npwd.Value)
cpwd=trim(TheForm.cpwd.Value)

if opwd="" then
  msgbox "請輸入舊密碼！"
  exit sub
end if

if npwd="" then
  msgbox "請輸入新密碼！"
  exit sub
end if
 
if cpwd="" then
  msgbox "請輸入確認密碼！"
  exit sub
end if

if npwd<>cpwd then
  msgbox "新密碼與確認密碼不一致！"
  exit sub
end if

if ucase(opwd)=ucase(npwd) then
msgbox "新密碼不得與舊密碼相同！"
exit sub
end if

if len(npwd)<3 then
msgbox "新密碼長度不得小于3位！"
exit sub
end if

TheForm.submit

End Sub
//-->
</SCRIPT>


<meta name="Microsoft Theme" content="mstheme1530 1111, default">
</head>

<body>
<form method="POST" action="Chpwd.asp" name="myform" target="_self">
<div align="center">
  <center>
<table width="100%" height="100%"><tr>
    <td valign="middle" align="center">
<div align="center">
  <center>
<table width="256" height="100" cellspacing="0" cellpadding="0" border="1" bordercolor="#FFFFFF"><tr><td>
  <div align="center">
    <center>
    <table border="0" width="256" height="100" cellspacing="0" cellpadding="0" bgcolor="#C0C0C0">
      <tr>
        <td width="92">　</td>
        <td width="160" colspan="2">　</td>
      </tr>
    </center>
    <tr>
      <td width="92">
        <p align="center"><font size="3">舊 密 碼：</font></td>
      <td width="160" colspan="2"><input type="password" name="oPwd" size="20"></td>
      </tr>
      <tr>
        <td width="92">
          <p align="center"><font size="3">新 密 碼：</font></td>
        <td width="160" colspan="2"><input type="password" name="nPWD" size="20"></td>
      </tr>
      <tr>
        <td width="92">
          <p align="center"><font size="3">確認密碼：</font></td>
        <td width="160" colspan="2"><input type="password" name="cPwd" size="20"></td>
      </tr>
      <tr>
        <td width="92">　</td>
        <td width="160" colspan="2">
          <p align="center">　</td>
      </tr>
      <tr>
        <td width="92">　</td>
        <td width="80">
          <p align="center"><input type="button" value="確定" name="cmdOK"></p>
        </td>
        <td width="80">
          <p align="center"><input type="button" value="取消" name="Cancel" onclick="JavaScript:history.back();"></td>
      </tr>
      <tr>
        <td width="92">　</td>
        <td width="80">　</td>
        <td width="80">　</td>
      </tr>
    </table>
  </div>
</td></tr></table> 
  </center>
</div></tr></table>
  </center>
</div>
</form>
</body>

</html>

b>響應文件CHPWD.asp
<HTML>

<head>
<meta name="Microsoft Theme" content="mstheme1530 1111, default">
</head>

<BODY>
<table border="0" width="100%" cellspacing="0" cellpadding="0">
  <tr>
    <td width="100%" height="100%" align="center" valign="middle">
<%
 
  '  Variables
  dim rbox

  uid=session("SID_UID")
  opwd=request.form("opwd")
  npwd=request.form("npwd")
  cpwd=request.form("cpwd")
 
  if opwd="" then
  response.write "請輸入舊密碼！"
  response.end
  end if

if npwd="" then
  response.write "請輸入新密碼！"
  response.end
end if
 
if cpwd="" then
  response.write "請輸入確認密碼！"
  response.end
end if

if npwd<>cpwd then
  response.write "新密碼與確認密碼不一致！"
  response.end
end if

if ucase(opwd)=ucase(npwd) then
response.write "新密碼不得與舊密碼相同！"
response.end
end if

if len(npwd)<3 then
response.write "新密碼長度不得小于3位！"
response.end
end if

set rbox = Server.CreateObject("RbsBoxGen.NTUserManager")

' rbox.ResetPwd uid,npwd 
' rbox.Login uid,npwd
  rbox.ChangePwd uid,opwd,npwd
   
  if rbox.isok then
  set rbox = nothing
  response.write "密碼更改成功!"
  else
  set rbox = nothing
  response.write "舊密碼輸入錯誤！"
  end if
response.end 

%>
</td>
  </tr>
</table>
</BODY>
</HTML>

3.登陸驗證(ASP):
dim rbox
set rbox = Server.CreateObject("RbsBoxGen.NTUserManager")
'以下如果已在DLL的初始化事件中設置正確則無須設置,可提高安全性
'rbox.Domain="yourdomain"
'rbox.Admin="administrator"
'rbox.password="XXXXXX"
'rbox.Ntserver="yonrntserver"
'rbox.EmailAddress="@Xxx.xxx"
'rbox.ExchServer="yourExchangeServerName"
'rbox.ExchSite="yourExchangeSiteName"
'rbox.ExchOrganization="yourExchangeOrganizationName"


rbox.Login name,pass  'name:待驗證的用戶帳號,Pass:用戶密碼
Login=cbool(rbox.isok)  '如果rbox.isok為真,驗證通過.
set rbox = nothing
if Not Login then
  response.redirect Request.ServerVariables("HTTP_REFERER")
  response.end
end if