前一期为大家介绍了如何使用VBA结合Outlook批量发送邮件，需要批量为不同的人发送不同的附件等，可以很方便的批量发送。但缺点是需要事先配置Outlook邮箱。那有没有不需要配置Outlook即可批量发送邮件呢？答案是肯定的，那究竟什么是CDO？如何使用CDO批量发送邮件呢？接下来就一一为大家揭晓。

CDO(Collaboration Data Objects)：协作数据对象，从Exchange Server 2007和Outlook 2007开始，CDO 1.2.1作为不在产品安装的一部分。CDO 1.2.1是通过基于COM的API提供对Outlook兼容对象的访问的包。

既然知道了什么是CDO，那究竟如何在Excel中使用CDO并批量发送邮件呢？

使用CDO必须提供一个邮箱服务，可以使用QQ或163等，下面介绍如何开通QQ的邮箱服务。

1 登录QQ邮箱，进到主界面；

2 点击上图红色框中的【设置】，进入邮箱设置界面；

3 点击上图红色框中的【账户】，进入账户设置界面并找到【POP3/IMAP/SMTP...】等服务；

4 可以看到上图中有个小的红色框，我们需要开启相应的服务，便于发送邮件，可以只开启第一个POP3/SMTP服务。点击开启会弹出如下对话框，让我升级为16位授权码进行登录，请见下图：

5 点击上图中的立即升级，会让我们用指定的手机号发送短信到1069070069，如下图所示：

6 成功发送短信后，点击上图中的【我已发送】，会提示验证成功，然后生成授权码，如下图所示：

PS：请不要随意关闭和开启以上的服务，因为每发送一条短信，运营商会收取0.1元，每开启一项服务，就需要发送一条短信，所以安全是要付出代价的。

7 可以看到上图下面的提示：可以拥有多个授权码，所以无需记住该授权码并且不要告诉他人。这里我们需要记住该授权码，因为需要在Excel中使用。成功开启POP3/SMTP服务后，会发现状态变为已开启，如下图所示：

通过上面几个步骤的设置，准备工作就已经完成了，加下来就是批量发送邮件的核心代码函数(请注意代码中红色字体)：

'使用CDO发送邮件Public Function fSendEMailCDO(strTo As String, strSubject As String, strBody As String, Optional strAttachment As String = "", Optional strCC As String = "", Optional strBCC As String = "") As Object

Dim CDOMail As Variant

Dim strUser, strPwd As String

On Error Resume Next '出错后继续执行 Application.DisplayAlerts = False '禁用系统提示

strUser = "您的QQ号@qq.com" '请填写您的邮箱地址 strPwd = "授权码" '填写我们上面申请开通的授权码 If strTo = "" Then MsgBox "请输入收件人地址~"

If strSubject = "" Then MsgBox "请输入主题~"

If strBody = "" Then MsgBox "请输入正文内容~"

Set CDOMail = CreateObject("CDO.Message") '创建对象 CDOMail.From = strUser '设置发信人的邮箱

CDOMail.To = strTo '设置收信人的邮箱 If ChkEmail(strCC) = 0 Then

CDOMail.CC = strCC '设置抄送的邮箱 End If

If ChkEmail(strBCC) = 0 Then

CDOMail.BCC = strBCC '设置密送的邮箱 End If

CDOMail.Subject = strSubject '设定邮件的主题

If strBody Like "*html*" Then

CDOMail.HTMLBody = strBody '使用Html格式发送邮件 Else

CDOMail.TextBody = strBody '使用文本格式发送邮件 End If

Dim strArray

strArray = Split(strAttachment, "|")

For i = 0 To UBound(strArray)

CDOMail.AddAttachment ThisWorkbook.Path & "\" & strArray(i) '如果有多个附件，分别添加 Next

SUTl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址

With CDOMail.Configuration.Fields

.Item(SUTl & "smtpserver") = "smtp.qq.com" 'SMTP服务器地址 .Item(SUTl & "smtpserverport") = 465 'SMTP服务器端口 .Item(SUTl & "sendusing") = 2 '发送端口 .Item(SUTl & "smtpauthenticate") = 1 '远程服务器需要验证 .Item(SUTl & "smtpusessl") = 1 'SSL .Item(SUTl & "sendusername") = strUser '发送方邮箱名称 .Item(SUTl & "sendpassword") = strPwd '发送方邮箱密码 .Item(SUTl & "smtpconnectiontimeout") = 60 '连接超时(秒) .Update

End With

CDOMail.Send '执行发送 Set CDOMail = Nothing '发送成功后即时释放对象

Application.DisplayAlerts = True '恢复系统提示 Set fSendEMailCDO = Err '邮件发送情况End Function

如上的代码中都进行的详细的注释，也用到了前一期使用的检查邮件是否合规的ChkEmail函数。需要发送的邮件信息如下图所示：

为了能够调用fSendEMailCDO函数，我写了一个宏，用来循环调用该函数。宏代码如下：

Sub 发送邮件()

Dim errMsg As Object

Dim iCount As Integer, iTotal As Integer

Worksheets("Sheet1").Select

Range("A2").Select

iCount = 0

iTotal = 0

Do While ActiveCell.Value <> ""

Set errMsg = fSendEMailCDO(ActiveCell.Value, ActiveCell.Offset(0, 1).Value, ActiveCell.Offset(0, 2).Value, ActiveCell.Offset(0, 3).Value, ActiveCell.Offset(0, 4).Value, ActiveCell.Offset(0, 5).Value)

If errMsg.Number = 0 Then

iCount = iCount + 1

End If

iTotal = iTotal + 1

ActiveCell.Offset(1, 0).Select

Loop

MsgBox "共发送" & iTotal & "个，成功发送邮件" & iCount & "个！"

End Sub

把上面2个自定义函数(fSendEMailCDO和ChkEmail)和宏(发送邮件)放入同一个模块中，然后在工作表中增加一个按钮即可批量发送邮件了，请看如下演示：

今天的介绍就到此结束了，如果让我来选，我首选使用CDO进行批量邮件发送，因为方便快捷，也不需要借助于Outlook进行发送。而且发送邮箱的速度明显要比Outlook要快捷。

原创不易，每一个案例都是自己整理和自学而来。曾有多少次明明已经坚持不下去，想放弃了的时候，却还是因为舍不得。希望各位看官多多转发和点赞。给别人一点正能量的同时，也是给予自己正能量。Written by Steven in 20170425^_^

微信公众号：SaveUTime

SUT学习交流群：615356012，入群审核人：Steven

关注公众号，提高效率，节约您的时间！