利用Excel批量快速发送电子邮件(2)

第一步：上面的代码需要改一句（红色加粗文本，body改成

HTMLBody）：

?代码list-2

' 发送单个邮件的子程序

Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String) Dim objOL As Object Dim itmNewMail As Object '引用Microsoft Outlook 对象

Set objOL = CreateObject(\ Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail

.subject = subject '主旨

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

.HTMLbody = body '正文本文，仅仅这一行跟前面不同，其余都是一样的哦~

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .To = to_who '收件者

.Attachments.Add attachement '附件 .Display '启动Outlook发送窗口 SetTimer 0, 0, 0, AddressOf WinProcA End With Set objOL = Nothing Set itmNewMail = NothingEnd Sub

第二步：修改excel第三列（C列）的内容，这需要你懂一点点HTML语言

例如，希望在邮件中将“报税单”三个字变红，加粗，则将第三列的内容修改为： 您好，下面是这一周的，…

最终效果如图：

去发件箱里看看效果吧：

注意：在Excel里面编辑正文，进行加粗、加颜色的操作不会生效哦。必须用HTML自己来，sorry哦 不会HTML的朋友可以新浪微博follow我帮忙：@研究员Raywill

2. 如何替换正文部分内容

分两步：

1. 换Excel内容 2. 换代码

1. 换Excel内容：

将变化的部分用[==xxxx==]这样的形式替换掉。注意：中间没有空格。

例如上图，数字[==1==]会被E列的内容替换掉，[==2==]会被F列的内容替换掉，依此类推，如果有更多，就添加更多列，[==3==], [==4==]等等。

2. 换代码，将 \批量发送邮件\这一段程序完全替换成下面的代码：

'批量发送邮件 Sub BatchSendMail() Dim rowCount, endRowNo Dim newBody

Dim replaceCount, maxReplaceCount Dim pattern

endRowNo = Cells(1, 1).CurrentRegion.Rows.Count

'逐行发送邮件

For rowCount = 1 To endRowNo ' 替换当前行模板内容

maxReplaceCount = 2 ' 有几处替换就写几，例子中有两处，就写2 newBody = Cells(rowCount, 3)

For replaceCount = 1 To maxReplaceCount

pattern = \

newBody = WorksheetFunction.Substitute(newBody, pattern, Cells(rowCount, 4 + replaceCount)) Next

' 替换好了，发邮件咯！

SendMail Cells(rowCount, 1), Cells(rowCount, 2), newBody, Cells(rowCount, 4) Next End Sub

注意：上面“maxReplaceCount = 2\这一行代码，2需要改成你自己的值，替换几个地方就写几（新添加了几个列就写几）上面添加了E、F两列，就是2，如果你添加了3处替换（E、F、G列），就写3.

不过，对于需要重复替换的内容，不需要添加新列，例如，《大话西游》在邮件中出现了两次，可以重复使用[==2==]来代表。

3. 如何发送多附件

成下面的样子即可：

在实际应用场景中可能需要发送多封附件，其实很简单，将SendMail子程序修改

' 发送单个邮件的子程序

Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String) Dim objOL As Object Dim itmNewMail As Object Dim attaches Dim attach

'引用Microsoft Outlook 对象

Set objOL = CreateObject(\ Set itmNewMail = objOL.CreateItem(olMailItem) With itmNewMail

.subject = subject '主旨 .HTMLbody = body '正文本文 .To = to_who '收件者

.Display '启动Outlook发送窗口 attaches = Split(attachement, \

For Each attach In attaches If (Len(attach) > 0) Then .Attachments.Add attach End If Next

SetTimer 0, 0, 0, AddressOf WinProcA