基于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 
|