VBA Outlook邮件自动化：高效集成Excel数据与列标题的策略

' 这种方式只捕获A列最后一行非空单元格所在的行，并扩展13列
Set MyData = ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13)

Dim MyData As Range
With ThisWorkbook.Worksheets("Database")
    ' 从A1单元格开始，到A列最后一行非空单元格所在的行，并向右扩展13列
    Set MyData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
End With

' 在一个标准模块中定义
Option Explicit

Private Sub cmdEmail_Click()
    Dim HTMLBody As String
    ' 调用函数生成邮件HTML正文
    HTMLBody = EmailHTMLFullRange ' 或 EmailHTMLHeaderAndLastRow 如果有特殊需求

    ' 发送邮件
    Call SendEmail(HTMLBody)

    ' 执行文件操作
    Call CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit
End Sub

' 发送Outlook邮件的子程序
Sub SendEmail(HTMLContent As String)
    Dim OLApp As Outlook.Application
    Dim OLMail As Object

    Set OLApp = New Outlook.Application
    Set OLMail = OLApp.CreateItem(0)

    ' 尝试登录Outlook会话，如果需要
    On Error Resume Next ' 忽略可能出现的错误，例如Outlook已运行
    OLApp.Session.Logon
    On Error GoTo 0 ' 恢复错误处理

    With OLMail
        .To = "" ' 收件人地址
        .CC = "" ' 抄送地址
        .BCC = "" ' 密送地址
        .Subject = "Quality Alert - 数据报告" ' 邮件主题
        .HTMLBody = "<P><font size='6' face='Calibri' color='black'>Quality Issue Found<br><br> Please reply back with what adjustments have been made to correct this issue. </font></P>" & HTMLContent
        .Display ' 显示邮件，允许用户编辑后发送
        ' .Send ' 直接发送邮件，如果不需要用户干预
    End With

    Set OLMail = Nothing
    Set OLApp = Nothing
End Sub

' 定义并返回需要转换为HTML的Excel数据范围
Function EmailData() As Range
    With ThisWorkbook.Worksheets("Database")
        ' 确保范围从A1开始，包含所有数据和标题
        Set EmailData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
    End With
End Function

' 生成包含完整数据范围的HTML字符串
Function EmailHTMLFullRange() As String
    EmailHTMLFullRange = RangetoHTML(EmailData)
End Function

' 复制、保存、关闭并删除数据库文件的子程序
Sub CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit()
    Dim ws As Worksheet
    Dim wb As Workbook

    Set ws = ActiveWorkbook.Sheets("Database")
    ws.Copy ' 复制工作表到新工作簿

    Set wb = ActiveWorkbook ' 新工作簿成为活动工作簿
    wb.SaveAs "C:\Temp\Database.xlsx" ' 更改为实际的保存路径
    wb.Close SaveChanges:=False
    Kill "C:\Temp\Database.xlsx" ' 删除临时文件

    Set ws = Nothing
    Set wb = Nothing
End Sub

' 生成仅包含标题行和最后一行数据的HTML字符串
Function EmailHTMLHeaderAndLastRow() As String
    Dim Target As Range
    Dim tempHTML As String

    Set Target = EmailData ' 获取包含所有数据和标题的范围

    ' 临时隐藏中间行，只保留标题行和最后一行
    With Target
        ' 确保RangetoHTML函数能够处理隐藏行
        .EntireRow.Hidden = msoTrue ' 隐藏目标范围内的所有行
        .Rows(1).Hidden = msoFalse ' 取消隐藏第一行（标题行）
        .Rows(.Rows.Count).Hidden = msoFalse ' 取消隐藏最后一行数据
    End With

    ' 将处理后的可见范围转换为HTML
    tempHTML = RangetoHTML(Target)

    ' 恢复所有行的可见性，以避免影响原始工作表
    Target.EntireRow.Hidden = msoFalse

    EmailHTMLHeaderAndLastRow = tempHTML
End Function

' 将Excel Range转换为HTML字符串的函数
Function RangetoHTML(rng As Range) As String
    Dim fso As Object
    Dim ts As Object
    Dim TempFolder As String
    Dim TempFileName As String
    Dim TempFile As String
    Dim wb As Workbook
    Dim ws As Worksheet

    ' 获取临时文件夹路径
    TempFolder = Environ$("temp") & "\"
    TempFileName = "email_temp.htm"
    TempFile = TempFolder & TempFileName

    ' 复制指定的范围
    rng.Copy

    ' 创建一个新的工作簿并将复制的内容粘贴到其中
    Set wb = Workbooks.Add(xlWBATWorksheet)
    Set ws = wb.Sheets(1)
    ws.Cells(1).PasteSpecial xlPasteAll ' 粘贴所有内容，包括格式

    ' 将新工作簿的已使用范围发布为HTML文件
    wb.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, _
                         Sheet:=ws.Name, Source:=ws.UsedRange.Address, _
                         HtmlType:=xlHtmlStatic).Publish (True)

    ' 读取生成的HTML文件内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) ' 1表示读取，-2表示使用系统默认编码
    RangetoHTML = ts.ReadAll
    ts.Close

    ' 清理：关闭临时工作簿并删除HTML临时文件
    wb.Close SaveChanges:=False
    Kill TempFile

    ' 释放对象内存
    Set fso = Nothing
    Set ts = Nothing
    Set wb = Nothing
    Set ws = Nothing
End Function