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（）。