3,248
社区成员
发帖
与我相关
我的任务
分享源码放送:兼复NT上如何做一个电子邮局系统?(good5555)
好久没有来,看到 <(good5555)在NT上如何做一个电子邮局系统>的帖子又冒出来了,所以决定源码放送,希望多多捧场,见笑了.
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
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
...全文
