Excel VBA 实现自动发送邮件

tsiensun

< 苏州 > 信息化、自动化、精益制造

项目准备
Excel VBA 工具引用
邮件发送的基础代码
收件人管理
附件管理
邮件正文图片添加的方法
邮件正文表格添加的方法
全功能代码

1：项目准备

启用宏的工作簿：新建一个Excel，另存为.xlsm格式

Outlook配置：Outlook中正确配置发信人的邮箱信息，否则无法实现邮件发送

（Outlook根据版本不同，配置的方法有细微不同，建议网络搜索学习）

备注：Outlook 和 Excel 都是Microsoft Office套件里的应用。

2：Excel VBA 工具引用

工具引用：Microsoft Outlook 16.0 Object Library

（根据Outlook版本不同，会有细微差别）

3：邮件发送基础实例

'工具->引用->Microsoft Outlook 16.0 Object Library
'或者  Set Mail = CreateObject("Outlook.Application")
Sub SendEmail()
    Dim Mail As Outlook.Application
    Set Mail = New Outlook.Application
    Dim objMail As Outlook.MailItem
    Set objMail = Mail.CreateItem(olMailItem)
    With objMail
        .Subject = "My Test Mail"  '主题
        .To = "xxxxxx@outlook.com" '收件人
        .CC = "xxxxx@hotmail.com"  '抄送
        .BCC = "xxxxx@sina.cn"     '密送
        .BodyFormat = olFormatHTML
        .HTMLBody = "<h2>My First Mail</h2>" '正文
        .Attachments.Add "D:\RunLog.txt"     '附件
        .Send '执行发送
    End With
End Sub

<如代码里注释说明一样，对于Outlook模块的引用，可以用CreateObject的方式实现，这样不用在菜单里进行引用操作，但该方法会使代码编辑缺少必要的提示>

代码部分与实际邮件部分的对应关系

代码中缺少发件人信息，是因为该程序调用的是Outlook程序，正常使用中的Outlook，是配置有发件人信息的。其它的基本与实际E-mail里的操作或填写内容一致。

Bodyformat：

正文文本格式决定了用于显示消息文本的标准。Microsoft outlook 提供三种正文文本格式选项: 纯文本、富文本(rtf)和 html。当 bodyformat 属性从 rtf 切换到 html 时，所有文本格式都将丢失，反之亦然。

BodyFormat值设置

名称	值	说明
olFormatHTML	2	HTML 格式
olFormatPlain	1	纯文本格式
olFormatRichText	3	RTF 格式
olFormatUnspecified	0	未指定的格式

对于正文内容和格式较为复杂的Mail，bodyformat建议设置为HTML，对于简单句的Mail，从简单的角度出发，设置为纯文本较为方便些。

4：收件人管理

参见基础代码，收件人，抄送，密送，三类收件人都是代码写死的，这样不利于后期的收件人管理，增加或删除名单都会涉及代码的修改，十分麻烦的。

.To = "xxxxxx@outlook.com" '收件人
.CC = "xxxxx@hotmail.com"  '抄送
.BCC = "xxxxx@sina.cn"     '密送

解决该类问题的通行办法是创建一个配置文件，或者数据库，用代码进行访问调用。

考虑到Excel本身就是一个强大的表格工具，所以对于Excel VBA应用，调用自身表格内容会是一个十分便捷的配置管理方法。

首先制作一个收件人管理表。

首先确定一个原则:收件人信息都是用字符串的方式提供给程序的，有多个收件人时，必须用“;”(英文的分号)隔开。

当我们制作完一个收件人管理表格后，程序的收件人添加问题就变成了表格读取问题和字符串的拼接问题。

VBA中我们可以用function函数来实现功能的模块化，因为function函数是带返回值的

Private Function 收件人(Rng As Range) As String
    收件人 = ""
    Dim Rr As Integer
    Rr = 2
    While Rng.Cells(Rr, 1) <> ""
        收件人 = 收件人 & Rng.Cells(Rr, 1)
        If Rng.Cells(Rr + 1, 1) <> "" Then 收件人 = 收件人 & ";"
        Rr = Rr + 1
End Function

我们将收件人所在的那一列作为参数传入function，函数自动读取收件人，并组成收件人字符串返回给调用者。

基础代码相应部分可被修改为

.To = 收件人(Sheet1.[A:A])     '收件人 在A列
.CC = 收件人(Sheet1.[B:B])     '抄送 在B列
.BCC = 收件人(Sheet1.[C:C])    '密送 在C列

5：附件的管理

我们看基础代码

 .Attachments.Add "D:\RunLog.txt"     '附件

在基础代码里，我是仅增加了一个附件，当需要添加多个附件时就需要调用多次.add

再实现附件添加模块化之前，我们需要研究如何进行附件的列表确认。对于多变的，需要经常维护的附件列表，手动在代码里进行.Attachments.Add显然是不现实的。

对于这个问题，我们可以用表格的形式，或文件夹遍历的形式进行。具体采用哪种方式取决于具体的需要。

这里我假设需要添加的附件已经写在了表格里。我们就可以用如下函数进行自动装载，整个函数类似收件人管理函数，但无需返回，在传参上略微复杂些

Private Sub 附件添加(附件 As Outlook.Attachments, Rng As Range)
    Dim Rr As Integer
    Rr = 2
    While Rng.Cells(Rr, 1) <> ""
        附件.Add Rng.Cells(Rr, 1).Text
        Rr = Rr + 1
End Sub

这样基础代码中的附件添加可以改写为

   附件添加 .Attachments, Sheet1.[D:D]

6：邮件正文图片添加

如果邮件的正文仅仅就是一句话，那么基础代码已经足够了。

但我们的mail，往往是图文并茂的，不仅有带格式的文字，还有漂亮表格，甚至夹插着图片。

Html可以提供这样的需求，正如常见的网页那样。

需要注意的是，Mail里的html和网页里的html是有所区别的，主要区别用“阉割版”这样的说法可能更容易理解。但它不影响表格，图片，文字的完美呈现，所以它也是足够受用的。

Mail正文里添加图片

.BodyFormat = olFormatHTML
.HTMLBody = "<img src='F:\图片汇总\PHOTO.png'>" '正文
.Display

修改过的基础代码正文编辑部分。Html中我写入了一个img标签，并且加载了本地F盘里的一个图片。

这里需要特别注意的是：在用html设置好.HTMLBody后，我启用了一个.Display方法。该方法会让Outlook在屏幕上一闪而过，它是模拟的Outlook手动编辑的过程，可以将Html中引用的本地图片加载并修正到网络地址。否则对方收到Mail时，是无法正确显示图片的。

还有一个十分诡异的事情，如果img标签里设置了width和height参数，接收方往往是不能正确显示图片的，其中的原因不得而知。

如果想得到能控制尺寸的正文图片，需要用如下方法进行

.Attachments.Add "F:\图片汇总\PHOTO.png"
.BodyFormat = olFormatHTML
.HTMLBody = "<img src='cid:PHOTO.png' width='100' height='100'>" 
.Display

即，先将图片作为附件添加，然后img的src属性以cid：的方式进行引用。和直接引用图片地址相比，该方法必须提供width和height尺寸信息，否则也是不能正确显示的。

7：邮件正文表格添加

邮件正文添加表格，是通过HTML来实现的，当我们将自动邮件与Excel相结合时，通常希望能发送和Excel表格里一样的内容。如果我们将Excel里每一个关键属性都对应到Html属性里，通过编码的方式是可以实现的，单纯从技术的实现上，是不错的逻辑训练过程，但的确辛苦。

可喜的是，Excel里自带有表格区域向html的转换方法，它通过先将特定的区域保存为htm格式，然后再以文件读取的方式加载到.HTMLBODY中。

文件读取，我们首先需要到工具里引用“Microsoft Scripting Runtime”库，该库提供了一个强大的文件管理功能，可以用它轻松整体读取一个文件。

我们同样可以将这样的方法进行封装

 Function Range_to_Html(Rng As Range) As String
    Dim PO As PublishObject
    Set PO = ThisWorkbook.PublishObjects.Add(xlSourceRange, "D:\Result.htm", Rng.Parent.Name, Rng.Address, xlHtmlStatic)
    PO.Publish True
    PO.Delete
    Dim FS As FileSystemObject
    Set FS = New FileSystemObject
    Dim TS As TextStream
    Set TS = FS.OpenTextFile("D:\Result.htm", ForReading, True, TristateUseDefault)
    Range_to_Html = TS.ReadAll
End Function

该函数，要求一个期望加载到邮件正文的区域，其返回的就是代表那个表区域的HTML代码.

.HTMLBody = Range_to_Html(Sheet2.[A1:O63])

8 全功能代码

'工具->引用->Microsoft Outlook 16.0 Object Library
'或者  Set Mail = CreateObject("Outlook.Application")
Sub SendEmail()
    Dim mail As Outlook.Application
    Set mail = New Outlook.Application
    Dim objMail As Outlook.MailItem
    Set objMail = mail.CreateItem(olMailItem)
    With objMail
        .Subject = "My Test Mail"  '主题
        .To = 收件人(Sheet1.[A:A]) '收件人
        .CC = 收件人(Sheet1.[B:B])  '抄送
        .BCC = 收件人(Sheet1.[C:C])    '密送
         附件添加 .Attachments, Sheet1.[D:D] '添加附件
        .BodyFormat = olFormatHTML
        .HTMLBody = Range_to_Html(Sheet2.[A1:O63]) '正文
        .Display
        .Send '执行发送
    End With
End Sub
Private Sub 附件添加(附件 As Outlook.Attachments, Rng As Range)
    Dim Rr As Integer
    Rr = 2
    While Rng.Cells(Rr, 1) <> ""
        附件.Add Rng.Cells(Rr, 1).Text
        Rr = Rr + 1
End Sub
Private Function 收件人(Rng As Range) As String
    收件人 = ""
    Dim Rr As Integer
    Rr = 2
    While Rng.Cells(Rr, 1) <> ""
        收件人 = 收件人 & Rng.Cells(Rr, 1)
        If Rng.Cells(Rr + 1, 1) <> "" Then 收件人 = 收件人 & ";"
        Rr = Rr + 1
End Function
'工具->引用-> Microsoft Scripting Runtime
Function Range_to_Html(Rng As Range) As String
    Dim PO As PublishObject
    Set PO = ThisWorkbook.PublishObjects.Add(xlSourceRange, "D:\Result.htm", Rng.Parent.Name, Rng.Address, xlHtmlStatic)
    PO.Publish True
    PO.Delete