用cdo的Exchange的一点点东西

cheng029

　　以前的一个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