《VBA信息获取与处理》教程(版权10178984)是我推出第六套教程，目前已经是第一版修订了。这套教程定位于最高级，是学完初级，中级后的教程。这部教程给大家讲解的内容有：跨应用程序信息获得、随机信息的利用、电子邮件的发送、VBA互联网数据抓取、VBA延时操作，剪贴板应用、Split函数扩展、工作表信息与其他应用交互，FSO对象的利用、工作表及文件夹信息的获取、图形信息的获取以及定制工作表信息函数等等内容。程序文件通过32位和64位两种OFFICE系统测试。是非常抽象的，更具研究的价值。

教程共两册,二十个专题。今日分享内容是：VBA信息获取与处理专题五第二节：根据地址不同分发简单邮件

【分享成果，随喜正能量】224面对他人的优秀，智者随喜，愚者比较。随喜他人的优秀，心里生出的是欢喜与向往，与他人的优秀做比较，心里生出的则是傲慢与偏见。要相信每个人都会有自己的闪光点，以一颗平等心，真诚的随喜他人的优秀，见贤思齐，修好自己的本领，静待自我人生的高光时刻。

专题五 VBA利用CDO发送电子邮件

第二节 根据地址不同分发简单邮件

在上一讲中我们讲了简单邮件的发送，我们这讲的内容是讲解如何根据工作表的指定地址分发邮件。

如下图：

上述表格是参加一次会议的各部门人员安排，需要各部门长接到邮件后按人数把人员反馈，如果群发那就太low了，我们要单独给各个部门。这节我们就来实现这个课题。

1 分发邮件的思路分析

为了实现我们刚才提到的目的，我们先把整个表研究一下，首列是收件人的地址，第二列到第第四列是部门，最后一列是要求的人数。

我们将邮件的内容设计成如下简单的格式，根据需要重复发送；

部门+领导+称呼：

贵部门参加会议的人数为：*人,请安排。

当然，以上的格式需要用HTML语言来编写。

2 发送邮件的自定义函数

上一讲中，我们利用了CDO完成邮件发送的简单过程，我们体会到，其中参数非常多，为此，我封装了一个自定义函数，来完成邮件发送的任务，这样只需在主程序中完成这些参数的定义即可。我们先看这个自定义函数SendEMailC的代码：

Function SendEMailC(Subject As String, FromAddress As String, ToAddress As String, _

MailBody As String, _

SMTP_Server As String, _

BodyFileName As String, _

Mailsendpassword As String, _

Optional Attachments As Variant = Empty) As Boolean

'常量的命名

Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"

Const cdoSendUsingPort = 2

Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"

Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"

Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"

Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"

Const cdoBasic = 1

Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"

Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"

Dim objConfig

Dim objMessage

Dim Fields

' 确保所需参数存在且有效

If Len(Trim(Subject)) = 0 Then

SendEMailC = False

Exit Function

End If

If Len(Trim(FromAddress)) = 0 Then

SendEMailC = False

Exit Function

End If

If Len(Trim(SMTP_Server)) = 0 Then

SendEMailC = False

Exit Function

End If

'传入的参数

' Subject: 电子邮件的主题行.

' FromAddress: 是发送电子邮件的地址

' ToAddress: 是电子邮件将发送到的地址

' MailBody: 要作为邮件正文的文本.

' SMTP_Server: 是传出邮件服务器的名称.

' BodyFileName: 是将用作消息正文的文本文件的名称.

' Attachments 要附加到邮件的单个文件名或文件名数组.

' Mailsendpassword 确认码或者密码

'引用

Set objMessage = CreateObject("CDO.Message")

'对象的引用

Set objConfig = objMessage.Configuration

Set Fields = objConfig.Fields

With Fields

.Item(cdoSendUsingMethod) = cdoSendUsingPort

.Item(cdoSMTPServer) = SMTP_Server ' <smtp邮件发送服务器(可修正)>

.Item(cdoSMTPServerPort) = 25

.Item(cdoSMTPConnectionTimeout) = 10

.Item(cdoSMTPAuthenticate) = cdoBasic

.Item(cdoSendUserName) = FromAddress '<发送者邮件地址(可修正)>

.Item(cdoSendPassword) = Mailsendpassword '<发送者邮件密码(可修正)>

.Update

End With

'邮件的设置

With objMessage

'.BodyPart.Charset = "shift-jis" ' <邮件内容编码（日语可以用）>

.To = ToAddress ' <接收者邮件地址>

.From = FromAddress ' <发送者邮件地址,与上面设置相同>

.Subject = Subject ' <邮件主题>

' .htmlBody ' <邮件内容>

'假如传入的参数有内容则引用，也可以从文件中导入

If MailBody <> vbNullString Then

.HtmlBody = MailBody

Else

If BodyFileName <> vbNullString Then

If Dir(BodyFileName, vbNormal) <> vbNullString Then

' 从文件BodyFileName导入正文文本

FNum = FreeFile

S = vbNullString

Body = vbNullString

Open BodyFileName For Input Access Read As #FNum

Do Until EOF(FNum)

Line Input #FNum, S

Body = Body & vbNewLine & S

Loop

Close #FNum

.HtmlBody = Body

Else

'BodyFileName 没有发现

SendEMailC = False

Exit Function

End If

End If

End If

'添加附件

If IsArray(Attachments) = True Then

' 附加附件的所有文件.

For N = LBound(Attachments) To UBound(Attachments)

' 如果为数组将每个文件传入

If Attachments(N) <> vbNullString Then

If Dir(Attachments(N), vbNormal) <> vbNullString Then

.AddAttachment Attachments(N)

End If

End If

Next

Else

' 不为数组则传入文件

If Attachments <> vbNullString Then

If Dir(CStr(Attachments), vbNormal) <> vbNullString Then

.AddAttachment Attachments

End If

End If

End If

'判断邮件是否发送成功

On Error Resume Next

Err.Clear

.Send

tt = Err.Number

If Err.Number = 0 Then

SendEMailC = True

Else

SendEMailC = False

Exit Function

End If

End With

Set Fields = Nothing

Set objMessage = Nothing

Set objConfig = Nothing

End Function

代码的截图：

代码的讲解：这个函数我在后面还有讲解。

我20多年的VBA实践经验，全部浓缩在下面的各个教程中，教程学习顺序：