基于ADSI的NT帐号及Exchange Server帐号申请及验证模块源代码
1.安装ADSI2.52.创建一个新的ActiveX DLL工程,工程名:RbsBoxGen,类名:NTUserManager3.执行工程-引用将下列库选上: 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 settingsPublic Const LOGON_CMD = "logon.cmd"Public Const INCOMING_MESSAGE_LIMIT = 1000Public Const OUTGOING_MESSAGE_LIMIT = 1000Public Const WARNING_STORAGE_LIMIT = 8000Public Const SEND_STORAGE_LIMIT = 12000Public Const REPLICATION_SENSITIVITY = 20Public Const COUNTRY = "US"' Mailbox rights for Exchange security descriptor (home made)Public Const RIGHT_MODIFY_USER_ATTRIBUTES = &H2Public Const RIGHT_MODIFY_ADMIN_ATTRIBUTES = &H4Public Const RIGHT_SEND_AS = &H8Public Const RIGHT_MAILBOX_OWNER = &H10Public Const RIGHT_MODIFY_PERMISSIONS = &H80Public 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 = 1Type ACL AclRevision As Byte Sbz1 As Byte AclSize As Integer AceCount As Integer Sbz2 As IntegerEnd TypeType ACE_HEADER AceType As Byte AceFlags As Byte AceSize As LongEnd TypeType ACCESS_ALLOWED_ACE Header As ACE_HEADER Mask As Long SidStart As LongEnd TypeType SECURITY_DESCRIPTOR Revision As Byte Sbz1 As Byte Control As Long Owner As Long Group As Long Sacl As ACL Dacl As ACLEnd Type' Just an help to allocate the 2dim dynamic arrayPrivate Type mySID x() As ByteEnd Type' Declares : modified from VB5 API viewerDeclare Function InitializeSecurityDescriptor Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR, _ ByVal dwRevision As Long) As LongDeclare Function SetSecurityDescriptorOwner Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR, _ pOwner As Byte, _ ByVal bOwnerDefaulted As Long) As LongDeclare Function SetSecurityDescriptorGroup Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR, _ pGroup As Byte, _ ByVal bGroupDefaulted As Long) As LongDeclare Function SetSecurityDescriptorDacl Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR, _ ByVal bDaclPresent As Long, _ pDacl As Byte, _ ByVal bDaclDefaulted As Long) As LongDeclare Function SetSecurityDescriptorSacl Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR, _ ByVal bSaclPresent As Long, _ pSacl As Byte, _ ByVal bSaclDefaulted As Long) As LongDeclare Function MakeSelfRelativeSD Lib "advapi32.dll" _ (pAbsoluteSecurityDescriptor As SECURITY_DESCRIPTOR, _ pSelfRelativeSecurityDescriptor As Byte, _ ByRef lpdwBufferLength As Long) As LongDeclare Function GetSecurityDescriptorLength Lib "advapi32.dll" _ (pSecurityDescriptor As SECURITY_DESCRIPTOR) As LongDeclare Function IsValidSecurityDescriptor Lib "advapi32.dll" _ (pSecurityDescriptor As Byte) As LongDeclare Function InitializeAcl Lib "advapi32.dll" _ (pACL As Byte, _ ByVal nAclLength As Long, _ ByVal dwAclRevision As Long) As LongDeclare Function AddAccessAllowedAce Lib "advapi32.dll" _ (pACL As Byte, _ ByVal dwAceRevision As Long, _ ByVal AccessMask As Long, _ pSid As Byte) As LongDeclare Function IsValidAcl Lib "advapi32.dll" _ (pACL As Byte) As LongDeclare Function GetLastError Lib "kernel32" _ () As LongDeclare 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 LongDeclare 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 LongDeclare 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 BooleanDim oNS As IADsOpenDSObjectDim User As IADsUserDim 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 FunctionCreate_NT_Account_Error: Create_NT_Account = False Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred creating NT account for user " & UserNameEnd 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 BooleanDim Domain As IADsDomainDim 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 BooleanDim Container As IADsContainerDim strRecipContainer As StringDim Mailbox As IADsDim rbSID(1024) As ByteDim OtherMailBox() As VariantDim sSelfSD() As ByteDim encodedSD() As ByteDim I As IntegerDim 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 FunctionCreate_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 BooleanDim strRecipContainer As StringDim Container As IADsContainerDim 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 FunctionDelete_Exchange_MailBox_Error: Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred deleting Mailbox for user " & UserNameEnd 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 LongDim SecDesc As SECURITY_DESCRIPTORDim I As IntegerDim tACL As ACLDim tACCESS_ALLOWED_ACE As ACCESS_ALLOWED_ACEDim pSid() As ByteDim pACL() As ByteDim pACESID() As mySIDDim Longueur As LongDim 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 FunctionSDError: MakeSelfSD = 0End 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 LongDim rc As LongDim pDomain() As ByteDim lSID As Long, lDomain As LongDim 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 FunctionSIDError: GetSID = 0End 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 StringDim Result As LongDim DCName As StringDim DCNPtr As LongDim DNArray() As ByteDim MNArray() As ByteDim 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 ByteDim pDomain(512) As ByteDim IReturn As LongDim I As IntegerDim NtDomain As StringNtDomain = 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 IEnd Sub5.将下列代码粘贴到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.ServerEnd SubPublic Sub GetUserInfo() '~~~~~~~~~~~~~~~~~~ ERROR CODE ~~~~~~~~~~~~~~~~' On Error GoTo ErrorCode '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~txtUserName = MyRequest.Form("UID")txtPwd = MyRequest.Form("PWD")txtRealName = MyRequest.Form("Name")End SubPublic Sub DeleteUser() Call Delete_Exchange_Mailbox(False, txtDomain, txtAdmin, _ txtPassword, txtUserName, txtExchServer, _ txtExchSite, txtExchOrganization) Call Delete_NT_Account(txtDomain, txtAdmin, txtPassword, txtUserName)End SubPublic 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 SubEnd SubPublic Property Let Domain(ByVal vNewValue As Variant)txtDomain = vNewValueEnd PropertyPublic Property Let Admin(ByVal vNewValue As Variant)txtAdmin = vNewValueEnd PropertyPublic Property Let Password(ByVal vNewValue As Variant)txtPassword = vNewValueEnd PropertyPublic Property Let NTServer(ByVal vNewValue As Variant)txtNTServer = vNewValueEnd PropertyPublic Property Let EmailAddress(ByVal vNewValue As Variant)txtEMailAddress = vNewValueEnd PropertyPublic Property Let ExchServer(ByVal vNewValue As Variant)txtExchServer = vNewValueEnd PropertyPublic Property Let ExchSite(ByVal vNewValue As Variant)txtExchSite = vNewValueEnd PropertyPublic Property Let ExchOrganization(ByVal vNewValue As Variant)txtExchOrganization = vNewValueEnd PropertyPrivate Sub Class_Initialize() txtDomain = "XX" '此处该为主域名 txtAdmin = "administrator" '超级管理员帐号 txtPassword = "" '超级管理员密码 txtNTServer = "XXserver" '主域控制器主机名 txtEMailAddress = "@sina.net" '邮件服务器域名 txtExchServer = "XXserver" 'Exchange服务器的主机名 txtExchSite = "XX" 'Exchange站点名称 txtExchOrganization = "xxx" 'Exchange组织名称 bIsOk = TrueEnd SubPublic Property Get IsOK() As VariantIsOK = bIsOkEnd PropertyPublic Sub ChangePwd(ByVal UID As String, ByVal oPwd As String, ByVal nPwd As String)Dim o As IADsOpenDSObjectDim usr As IADsUserOn Error GoTo ErrMsgSet o = GetObject("WinNT:")Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID, UID, oPwd, 1)usr.ChangePassword oPwd, nPwdbIsOk = TrueExit SubErrMsg:bIsOk = FalseEnd SubPublic Sub ResetPwd(ByVal UID As String, ByVal nPwd As String)Dim o As IADsOpenDSObjectDim usr As IADsUserOn Error GoTo ErrMsgSet o = GetObject("WinNT:")Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID & ",user", txtAdmin, txtPassword, 1)usr.SetPassword nPwdbIsOk = TrueExit SubErrMsg:bIsOk = FalseEnd SubPublic Sub Login(ByVal UID As String, ByVal Pwd As String)Dim o As IADsOpenDSObjectDim usr As IADsUserDim nPwd As StringOn Error GoTo ErrMsgSet o = GetObject("WinNT:")Set usr = o.OpenDSObject("WinNT://" & txtDomain & "/" & UID & ",user", txtAdmin, txtPassword, 1)nPwd = Pwd & "X"usr.ChangePassword Pwd, nPwdusr.SetPassword PwdbIsOk = TrueExit SubErrMsg:bIsOk = FalseEnd Sub6.编译工程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" οnsubmit="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><% ' Variablesdim rboxset 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_OnClickDim TheFormSet TheForm = Document.MyFormopwd=trim(TheForm.opwd.Value)npwd=trim(TheForm.npwd.Value)cpwd=trim(TheForm.cpwd.Value)if opwd="" then msgbox "请输入旧密码！" exit subend ifif npwd="" then msgbox "请输入新密码！" exit subend if if cpwd="" then msgbox "请输入确认密码！" exit subend ifif npwd<>cpwd then msgbox "新密码与确认密码不一致！" exit subend ifif ucase(opwd)=ucase(npwd) thenmsgbox "新密码不得与旧密码相同！"exit subend ifif len(npwd)<3 thenmsgbox "新密码长度不得小于3位！"exit subend 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" οnclick="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 ifif npwd="" then response.write "请输入新密码！" response.endend if if cpwd="" then response.write "请输入确认密码！" response.endend ifif npwd<>cpwd then response.write "新密码与确认密码不一致！" response.endend ifif ucase(opwd)=ucase(npwd) thenresponse.write "新密码不得与旧密码相同！"response.endend ifif len(npwd)<3 thenresponse.write "新密码长度不得小于3位！"response.endend 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 ifresponse.end %></td> </tr></table></BODY></HTML>3.登陆验证(ASP):dim rboxset 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 = nothingif Not Login then response.redirect Request.ServerVariables("HTTP_REFERER") response.endend if
