VBA通过CDO发送邮件

VBA中发送邮件有很多方法，Jmail或者直接调用outlook，Jmail要求本机安装Jmail.dll库文件，调用outlook又要要求本机安装outlook并且配置好outlook收发邮件。

本文介绍使用Windows自带的cdosys.dll发送邮件。

不做多解释直接上代码了。

' CDO相关参数

Private Const cdoSendUsingMethod = _

    "http://schemas.microsoft.com/cdo/configuration/sendusing"

Private Const cdoSMTPServer = _

    "http://schemas.microsoft.com/cdo/configuration/smtpserver"

Private Const cdoSMTPServerPort = _

    "http://schemas.microsoft.com/cdo/configuration/smtpserverport"

Private Const cdoSMTPConnectionTimeout = _

    "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"

Private Const cdoSMTPAuthenticate = _

    "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"

Private Const cdoSMTPPassword = _

    "http://schemas.microsoft.com/cdo/configuration/sendpassword"

Private Const cdoSMTPUserId = _

    "http://schemas.microsoft.com/cdo/configuration/sendusername"

Private Const cdoSMTPUsessl = _

    "http://schemas.microsoft.com/cdo/configuration/smtpusessl"

Private Const cdoSendUsingPort = 2

Private Const cdoAnonymous = 0

Private Const cnsUseSSL = True

Private Const cdoLanguageCode = _

    "http://schemas.microsoft.com/cdo/configuration/languagecode"

' 文字编码

 

Public Const cdoUTF_8 = "utf-8"

'*******************************************************************************

' 邮件发信(CDO)

'*******************************************************************************

' 参数

'  MailSmtpServer : SMTP服务器

'  MailFrom       : 发件人地址

'  MailTo         : 收件人地址

'  MailCc         : CC

'  MailBcc        : BCC

'  MailSubject    : 邮件标题

'  MailBody       : 邮件内容

'  MailAddFile    : 添加附件 可选

'  MailCharacter  : 文字编码 可选

' [返回值]

'  正常"OK", 错误"NG"+错误信息

 

'*******************************************************************************

Public Function SendMailByCDO(MailSmtpServer As String, _

                              MailFrom As String, _

                              AccountPassword As String, _

                              MailTo As String, _

                              MailCc As String, _

                              MailBcc As String, _

                              MailSubject As String, _

                              MailBody As String, _

                              Optional MailAddFile As Variant, _

                              Optional MailCharacter As String)

    Const cnsOK = "OK"

    Const cnsNG = "NG"

    Dim objCDO As Object

    Dim vntFILE As Variant

    Dim IX As Long

    Dim strCharacter As String, strBody As String, strChar As String

    

    On Error GoTo SendMailByCDO_ERR

    SendMailByCDO = cnsNG

 

    strCharacter = cdoUTF_8 '"gb2312"

 

    strBody = Replace(MailBody, vbLf, vbCrLf)

 

    MailBody = Replace(strBody, vbCr & vbCrLf, vbCrLf)

    

    Set objCDO = CreateObject("CDO.Message")

    With objCDO

        With .Configuration.Fields

            .Item(cdoSMTPUsessl) = cnsUseSSL

            .Item(cdoSendUsingMethod) = cdoSendUsingPort

            .Item(cdoSMTPServer) = MailSmtpServer

            .Item(cdoSMTPServerPort) = 465               ' 端口号

            .Item(cdoSMTPConnectionTimeout) = 60            ' 超时

            .Item(cdoSMTPAuthenticate) = 1       ' 0

            .Item(cdoSMTPUserId) = MailFrom

            .Item(cdoSMTPPassword) = AccountPassword

            .Item(cdoLanguageCode) = strCharacter

            .Update                                         ' 设定更新

        End With

        .MimeFormatted = True

        .Fields.Update

        .From = MailFrom                        ' 发信人

        .To = MailTo                            ' 收件人

        If MailCc <> "" Then .CC = MailCc       ' CC

        If MailBcc <> "" Then .BCC = MailBcc    ' BCC

        .Subject = MailSubject                  ' 标题

        .HTMLBody = MailBody                    ' 邮件内容

        .HTMLBodyPart.Charset = strCharacter    ' 文字编码

        .TextBodyPart.Charset = strCharacter    ' 文字编码

        ' 附件

        If ((VarType(MailAddFile) <> vbError) And _

            (VarType(MailAddFile) <> vbBoolean) And _

            (VarType(MailAddFile) <> vbEmpty) And _

            (VarType(MailAddFile) <> vbNull)) Then

            If IsArray(MailAddFile) Then

                For IX = LBound(MailAddFile) To UBound(MailAddFile)

                    .AddAttachment MailAddFile(IX)

                Next IX

            ElseIf MailAddFile <> "" Then

                vntFILE = Split(CStr(MailAddFile), ",")

                For IX = LBound(vntFILE) To UBound(vntFILE)

                    If Trim(vntFILE(IX)) <> "" Then

                        .AddAttachment Trim(vntFILE(IX))

                    End If

                Next IX

            End If

        End If

        .Send                                   ' 发信

    End With

    Set objCDO = Nothing

    SendMailByCDO = cnsOK

    Exit Function

 

'-------------------------------------------------------------------------------

SendMailByCDO_ERR:

    SendMailByCDO = cnsNG & err.Number & " " & err.Description

    On Error Resume Next

    Set objCDO = Nothing

 

End Function

 

SendMailByCDO函数中调用了两个自定义的函数Replace（）和Split（）。