使用VBA实现EXCEL批量生成图表并发送

使用EXCEL VBA实现图表批量生成并发送

业务需求

office word2007的邮件合并功能是财务、文秘类工作经常使用的功能之一，该功能可以生成包含可变内容的批量邮件文档，广泛适用于发送工资条、成绩单、通知书等，这里不再赘述。笔者所在单位最近为加强员工考核管理工作力度，提出了一个类似于邮件合并功能，但使用邮件合并功能却不能实现的需求，下面用文字结合图表描述：

1.将员工百分制考核结果批量以图表(折线图)反应出来，每一条员工数据均生成一个类似于下图右侧的图表。

（图1）

2.使用类似于邮件合并方式实现员工考核图表的批量发送，将生成的图表插入邮件正文分别发送给每位员工。

（图2）

解决思路

思路一：使用https://www.360docs.net/doc/767446877.html,+Sqlserver（或ACCESS等，下同）开发一个网站，设置好权限，允许员工查看自己的反馈结果。

思路评价：可行，但达不到设想中的推送效果。

思路二：使用https://www.360docs.net/doc/767446877.html,+Sqlserver开发一个系统，内置图表模板，图表基于固定区域数据生成；为每位员工复制一份作为报表，将该员工数据填写到固定区域；将每位员工的报表作为附件发送给每位员工。

思路评价：可行，但开发量大，效果不直观。

思路三：使用https://www.360docs.net/doc/767446877.html,+Sqlserver开发一个系统，使用VS2008版以上自带控件或第三方控件如dotnetcharting，为每位员工生成一张图片，将该图片插入邮件发送给每位员工。

思路评价：可行，但开发量大。

思路四：使用excel VBA为每位员工生成一张图片，将该图片插入邮件发送给每位员工。这个思路一开始并没有列入考虑范围，主要原因是当时认为在excel中为每位员工生成一个图表是不可能的，即使能生成也没办法脱离excel工作薄，分别和员工对应起来并发送。最终采用本思路，是缘于笔者发现VBA可以非常容易地把图表导出为图片。

思路评价：可行，事实证明，开发量比想象的小很多。

开发环境准备

1.在运行该程序的电脑上安装Office Excel2007或以上版本；

2.正确配置OUTLOOK使之能够正常发送邮件；

3.打开Excel2007新建工作薄，把测试数据输入到sheet1工作表，把工作薄保存到工作目录（为方便后文描述，这里的目录设为“E:\excel-vba”），在该目录下新建“imgfile”子目录，以存放图片。示例数据如下：

注意：附件路径是个公式：=concatenate(“E:\excel-vba\imgfile\”,A1,”.jpg”) 含义是图片以员工姓名命名，这意味着员工姓名不可重复。

4.完成宏安全设置，如图所示：

（图3）

实现过程

这个业务需求实现包含两个难点，一是为每位员工生成对应的图片；二是批量发送带图片的邮件。基于这两点，笔者在excel工作薄中设置了两个按钮，编写了两段代码，分别对应上述两个问题。事实上，这两段代码完全可以整合到一起，这里为了方便理解，还是分开介绍。笔者采取代码中加入注释的方式帮助大家理解代码含义。

第一步，在sheet1中加入两个按钮，分别命名为“批量生成图表”和“批量发送邮件”。

第二步，分别为两个按钮指定如下宏代码：

Sub 批量生成图表()

Dim myChart, Ra As ChartObject

Dim myFileName As String

Dim i, j As Integer

With Sheet1

'先虚加一个图表对象,解决下文循环开头删除空集问题

Set myChart = .ChartObjects.Add(520, 40, 400, 250)

'取数据总行数，第一行为标题，最后一行为平均值

j = Sheet1.[b65536].End(xlUp).Row

'从第2行开始循环，i代表第几行

For i = 2 To j - 1

'清除原有图表

.ChartObjects.Delete

'.指定图表位置和大小

Set myChart = .ChartObjects.Add(520, 40, 400, 250)

With myChart.Chart

'第一个数据系列，员工各项考核值

.ChartType = xlLineMarkers

.SeriesCollection.NewSeries

.SeriesCollection(1).XValues = Sheet1.Range("b1:e1")

.SeriesCollection(1).Values = Sheet1.Range("b" & i & ":e" & i)

.SeriesCollection(1).Name = Sheet1.Range("a" & i)

'第二个数据序列，各项考核平均值，位于sheet最后一行

.SeriesCollection.NewSeries

.SeriesCollection(2).XValues = Sheet1.Range("b1:e1")

.SeriesCollection(2).Values = Sheet1.Range("b" & j & ":e" & j)

.SeriesCollection(2).Name = Sheet1.Range("a" & j)

'.指定图表生成的位置

'.Location Where:=xlLocationAsObject, Name:="Sheet1"

'显示标签值

.ApplyDataLabels ShowValue:=True

'显示图表标题

.HasTitle = True

.ChartTitle.Text = "员工考核反馈"

'.设置图表标题的字体

With .ChartTitle.Font

.Size = 20

.ColorIndex = 3

.Name = "华文新魏"

End With

'.设置图表区域的颜色

With .ChartArea.Interior

.ColorIndex = 8

.PatternColorIndex = 1

.Pattern = xlSolid

End With

'.设置绘图区域的颜色

With .PlotArea.Interior

.ColorIndex = 35

.PatternColorIndex = 1

.Pattern = xlSolid

End With

'.设置是否显示Y轴刻度

myChart.Chart.HasAxis(xlValue, xlPrima ry) = True

Set myChart = Sheet1.Cha rtObjects(1).Chart

'使用第一列值命名图像，请勿重复

myFileName = Sheet1.Cells(i, 1) & ".jpg"

On Error Resume Next

'.删除原有同名文件

Kill ThisWorkbook.Path & "\imgfile\" & myFileName

'.将图表转换为图像并输出到指定目录，使之与H列的值相对应

myChart.Export Filename:=ThisWorkbook.Path & "\imgfile\" & myFileName, Filtername:="JPG"

End With

'.清空对象

Set myChart = Nothing

Next i

End With

End Sub

Sub 批量发送邮件()

''要能正确发送并需要对Microseft Outlook进行有效配置

On Error Resume Next

Dim rowCount, endRowNo

'要正常运行下面这句,要将工具/引用中的Microseft Outlook 12.0 Object Library选上

Dim objOutlook As New Outlook.Application

Dim objMail As MailItem

'取得当前工作表与Cells(1,1)相连的数据区行数

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

'创建objOutlook为Outlook应用程序对象

Set objOutlook = New Outlook.Application

'开始循环发送电子邮件

For rowCount = 2 To endRowNo - 1

'创建objMail为一个邮件对象

Set objMail = objOutlook.CreateItem(olMailItem)

With objMail

'设置收件人地址（从通讯录表的'E-mail地址'列中获得）

.To = Cells(rowCount, 7)

'设置抄送人地址（从通讯录表的'抄送E-mail地址'列中获得）

'.CC = Cells(rowCount, 2)

'设置邮件主题

.Subject = Cells(rowCount, 6) & "(" & Cells(rowCount, 1) & ")"

'设置邮件内容格式，这里选择HTML

.BodyFormat = olFormatHTML

'设置邮件内容（从通讯录表的'内容'列中获得），这里的内容本质上是个网页，可先使用网页开发工具调整好格式，然后把源码粘贴到此处

.HTMLBody = "

员工考核反馈(" & Cells(rowCount, 1) & ")

"

'设置附件（如果以附件形式发送的话，这里选择不加附件）

'If Range("H" & rowCount).Value <> "" Then

'.Attachments.Add Range("H" & rowCount).Value

'End If

'显示邮件

.Display

'发送邮件

.Send

End With

On Error GoTo continue

continue:

On Error GoTo 0

' Set bjOutlook = Nothing

Set objMail = Nothing

Next

'销毁objOutlook对象

Set objOutlook = Nothing

'所有电子邮件发送完成时提示

MsgBox rowCount - 2 & "个员工的反馈信息发送成功！"

'如果发送成功，关闭Excel，这里选择不退出

If Application.Workbooks.Count = 1 Then

'Application.Quit

Else

'Workbooks("excel-vba.xls").Close

End If

End Sub

第三步，单击“批量生成图表”，程度运行结束后，在“imgfile”目录下可以看到每行

数据生成的图像文件；

第四步，单击“批量发送邮件”，程序运行结束后，每行数据对应的邮箱将收到类似图2的邮件。

结语

借助Excel VBA的强大功能，通过控制生成图表的参数，可以生成形式多样的图表。由于微软办公套件之间的协同性极强，使用VBA可以生成图文并茂的邮件并批量推送，充分体现数据价值。