首先，让我们给我们刚开始定义的子程序SayHello改个名，叫做GenerateAttachment，如下：
Sub GenerateAttachment() ' 定义一个变量，用于引用新建的 Workbook Dim newWorkbook As Workbook ' 定义一个变量，用于引用新增的 Worksheet Dim newWorksheet As Worksheet ' 定义一个工作表引用，用于引用当前工作簿的 'datasource' 工作表 Dim srcWorksheet As Worksheet ' 分别定义数据源标题的 Range 和数据 Range，用于获取数据 Dim rgTitleSrc As Range Dim rgDataSrc As Range ' 分别定义目标标题的 Range 和数据 Range，用于写入数据 Dim rgTitleDest As Range Dim rgDataDest As Range ' 标记当前选中行 Dim selectedRow As Integer ' 新增一个 Workbook，并引用 Set newWorkbook = Workbooks.Add On Error GoTo E ' 添加一个 Worksheet Set newWorksheet = newWorkbook.Sheets.Add On Error GoTo Dispose ' 将新建的 Worksheet 命名为 'attachment' newWorksheet.Name = "attachment" ' 获取到当前工作簿的 'datasource' 工作表引用 Set srcWorksheet = ThisWorkbook.Worksheets("datasource") On Error GoTo Dispose ' 激活数据源工作表，以复制数据 srcWorksheet.Activate On Error GoTo Dispose ' 设置当前选中行 selectedRow = Selection.Row On Error GoTo Dispose ' 选中标题区域 title Set rgTitleSrc = srcWorksheet.Range("A1", "C1") On Error GoTo Dispose ' 选中数据区域，当前选中行 Set rgDataSrc = srcWorksheet.Range("A" & selectedRow, "C" & selectedRow) On Error GoTo Dispose With newWorksheet ' 复制数据源标题 rgTitleSrc.Copy ' 将复制内容粘贴到 A1 .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False Application.CutCopyMode = False ' 复制数据源数据 rgDataSrc.Copy .Cells(2, "A").PasteSpecial Paste:=8 .Cells(2, "A").PasteSpecial xlPasteValues, , False, False .Cells(2, "A").PasteSpecial xlPasteFormats, , False, False ' 激活并选中目标工作表 newWorkbook.Activate newWorkbook.Sheets(newWorksheet.Index).Select '最终选中 A1 单元格 .Cells(1).Select On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo Dispose End With ' 将新建的 Workbook 保存到 "D:\xx.xlsx" 路径。 ' 这里如果文件已存在，会提示是否覆盖. ' 路径要使用 '\' 进行目录隔离，使用'http://www.likecs.com/'会报错 newWorkbook.SaveAs ("D:\xx.xlsx") On Error GoTo Dispose Dispose: ' 最后，关闭新建的 Workbook。 newWorkbook.Close E: End Sub那么现在，GenerateAttachment存在的意义，就只剩下在"D:\xx.xlsx"生成附件文件了。
接下来，让我们在GenerateAttachment上方添加一个函数，如下：
Sub SendMail() GenerateAttachment End Sub从代码我们可以看到，SendMail子程序调用了GenerateAttachment子程序，经过测试，这样和只有一个GenerateAttachment子程序产生的结果是一样的。
那么，接下来我们怎么办呢？
我们先创建一个Outlook进程，然后创建一个邮件消息，然后从我们的Excel中读取消息，设置新建邮件消息的内容以及将之前生成的附件添加到邮件中，修改SendMail代码如下：
Sub SendMail() ' 声明一个引用，用于引用我们的 OutLook 实例。 Dim mailApp As Object ' 声明引用，用于引用我们的邮件实例。 Dim mail As Object ' 用于访问源工作表中数据 Dim srcWorksheet As Worksheet ' 用于记录当前选中行 Dim selectedRow As Integer ' 生成附件 GenerateAttachment ' 获取到当前工作簿的 'datasource' 工作表引用 Set srcWorksheet = ThisWorkbook.Worksheets("datasource") On Error GoTo E ' 激活数据源工作表，以复制数据 srcWorksheet.Activate On Error GoTo E ' 设置当前选中行 selectedRow = Selection.Row On Error GoTo E ' 生成 Outlook 程序对象 Set mailApp = CreateObject("Outlook.Application") On Error GoTo Dispose ' 生成一个邮件信息 Set mail = mailApp.CreateItem(olMailItem) On Error GoTo Dispose With mail ' 设置收件人为源工作表的当前选中行的B列单元格的值 .To = srcWorksheet.Cells(selectedRow, "B").Value ' 设置抄送人 .CC = "" ' 设置密送人 .BCC = "" ' 设置邮件标题 .Subject = "一封新邮件" ' 设置附件，附件已经由 GenerateAttachment 子程序放在 ' D:\xx.xlsx，所以这里我们直接将其添加进来 .Attachments.Add "D:\xx.xlsx" ' 设置邮件内容文本，其中从A列取用户名，C列取消息 ' 然后合并，作为邮件体 .Body = srcWorksheet.Cells(selectedRow, "A").Value & "," & vbNewLine & srcWorksheet.Cells(selectedRow, "C").Value ' 最后，显示邮件信息 .Display End With Dispose: E: End Sub试运行，我们发现，生成了目标附件，并且弹出了一个Outlook新建邮件的窗口，如下：