用cdo的Exchange的一点点东西
以前的一个OA项目中可能用到要用到EXCHANGE做邮件，就稍微弄了一下，经常看到论坛里有人问，具体的不解释了。有需要的直接拷代码吧：）。如果在2003下，要在IIS里面设置一下应用程序权限改为Exchange pool什么的。但创建用户的权限在2003下我始终搞不定。注意事项：如果此代码在不是基于 Exchange 2000 Server 的计算机上运行，您必须在该计算机上安装 Exchange 2000 系统管理工具。如果不这样做，则 CDOEXM 将不可用，而且向 IMailboxStore 的强制转换将导致返回 InvalidCastException 响应：An unhandled exception of type 'System.InvalidCastException' occurred in MBTest.exe
Additional information:Specified cast is not valid. 见http://support.microsoft.com/default.aspx?scid=kb;zh-cn;313114#Explain4
开发环境：win2000+exchange2000.
（2005年8月21日重新整理）
'发送邮件
Public Function SendMail()Function SendMail(ByVal FromAddress As String, ByVal ToAddress As String, _
ByVal CcAddress As String, ByVal BccAddress As String, _
ByVal Subject As String, ByVal TextBody As String, _
ByVal AttachmentList As String) As String
Dim objCDOMessage As New CDO.Message
Dim vAttachmentList() As String
Dim n As Integer
With objCDOMessage
.From = FromAddress
.To = ToAddress
.CC = CcAddress
.BCC = BccAddress
.Subject = Subject
.TextBody = TextBody
vAttachmentList = Split(AttachmentList, ",")
For n = 0 To UBound(vAttachmentList)
.AddAttachment(vAttachmentList(n))
Next
.Send()
End With
SendMail = 1
exit_handle:
If Err.Number <> 0 Then
SendMail = 0
End If
objCDOMessage = Nothing
End Function
'新邮件提示
'当帐户密码为空时，无法用open方法打开sMailBoxURL,待测试解决
Public Function NewMailTip()Function NewMailTip(ByVal user, ByVal password)
Dim objInfo As New ActiveDs.WinNTSystemInfo
Dim objRec As New ADODB.Record
Dim objRS As New ADODB.Recordset
Dim sMailBoxURL As String
Dim server As String
server = objInfo.PDC
sMailBoxURL = "http://" & server & "/exchange/" & user & "/收件箱"
objRec.Open(sMailBoxURL, , ADODB.ConnectModeEnum.adModeReadWrite, ADODB.RecordCreateOptionsEnum.adOpenIfExists, , user, password)
Return objRec.Fields("urn:schemas:httpmail:unreadcount").Value
End Function
'取得用户邮件地址
Public Function GetMailAdress()Function GetMailAdress(ByVal user)
Dim objinfo As New ActiveDs.ADSystemInfo
Return (user & "@" & objinfo.DomainDNSName)
End Function
'创建新用户和邮箱
Public Function CreateUser()Function CreateUser(ByVal szFirstName As String, ByVal szLastName As String, ByVal szPassword As String, _
ByVal szAdminUserName As String, ByVal szAdminPassword As String) _
As Integer
'Create a user account and mailbox
Dim objCDOPerson As New CDO.Person
Dim objCDOEXMMailbox As CDOEXM.IMailboxStore
Dim n As Integer
Dim sLDAP As String
Dim sMailLDAP As String
Dim szAlias As String
Dim objInfoNt As New ActiveDs.WinNTSystemInfo
Dim objInfo As New ActiveDs.ADSystemInfo
Dim server As String
szAlias = szFirstName & szLastName
server = objInfoNt.PDC
sLDAP = "LDAP://" & server & "/CN=" & szAlias & ",CN=Users," & GetLdapDN()
On Error GoTo errhandler
With objCDOPerson
.FirstName = szFirstName
.LastName = szLastName
'set password doesn't expire
.Fields("userAccountControl").Value = 66048
.Fields("userPrincipalName").Value = szAlias
.Fields.Update()
.DataSource.SaveTo(sLDAP, , , , , szAdminUserName, szAdminPassword)
End With
sMailLDAP = "LDAP://" & server & "/CN=Mailbox Store (" & server & _
"),CN=First Storage Group,CN=InformationStore,CN=" & _
server & ",CN=Servers,CN=First Administrative Group," & _
"CN=Administrative Groups,CN=" & GetOrgName() & _
",CN=Microsoft Exchange,CN=Services,CN=Configuration," & _
GetLdapDN()
objCDOEXMMailbox = objCDOPerson
objCDOEXMMailbox.CreateMailbox(sMailLDAP)
With objCDOPerson
.Email = "SMTP:" & szAlias & "@" & objInfo.DomainDNSName
.Fields("mailnickname").Value = szAlias
.Fields("userPassword").Value = szPassword
.Fields.Update()
.DataSource.Save()
End With
CreateUser = 1
'clean up
objCDOEXMMailbox = Nothing
objCDOPerson = Nothing
Exit Function
' Error handling.
errhandler:
CreateUser = 0
objCDOEXMMailbox = Nothing
objCDOPerson = Nothing
End Function
'取得组织名称
Private Function GetOrgName()Function GetOrgName()
Dim iAdRootDSE As ActiveDs.IADs
Dim Conn As New ADODB.Connection
Dim Com As New ADODB.Command
Dim Rs As ADODB.Recordset
Dim varConfigNC As Object
Dim strQuery As String
' Get the configuration naming context.
iAdRootDSE = GetObject("LDAP://RootDSE")
varConfigNC = iAdRootDSE.Get("configurationNamingContext")
' Open the connection.
Conn.Provider = "ADsDSOObject"
Conn.Open("ADs Provider")
' Build the query to find the organization.
strQuery = "<LDAP://" & varConfigNC & ">;(objectCategory=msExchOrganizationContainer);name,cn,distinguishedName;subtree"
Com.ActiveConnection = Conn
Com.CommandText = strQuery
Rs = Com.Execute
' Iterate through the results.
While Not Rs.EOF
' Output the name of the organization.
Return Rs.Fields("cn").Value
Rs.MoveNext()
End While
'Clean up.
Rs.Close()
Conn.Close()
Rs = Nothing
Com = Nothing
Conn = Nothing
End Function
'取ldap目录
Private Function GetLdapDN()Function GetLdapDN()
Dim objinfo As New ActiveDs.ADSystemInfo
Dim szaDomTokens() As String
Dim szDomainDN As String
Dim szLdapDomain As String
Dim szDomainName As String
szDomainName = objinfo.DomainDNSName
szaDomTokens = Split(szDomainName, ".", -1, 1)
szDomainDN = Join(szaDomTokens, ",dc=")
szLdapDomain = "dc=" & szDomainDN
Return szLdapDomain
End Function
页:
[1]