如何修改Outlook VBA宏，实现Excel附件既作为附件发送又嵌入邮件正文

以下是调整后的完整代码，可实现你要求的「添加附件的同时，将附件内的表格插入邮件正文」需求，保留原有发件逻辑不变：

Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim email2_ As String
    Dim cc As String
    Dim subject_ As String
    Dim path_ As String
    ' 新增变量：用于读取附件Excel内容
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim tableHtml As String
    
    Set mainWB = ActiveWorkbook
    Sheets("Duplicates").Select
    Range("A1").Select

    ' 创建Outlook对象
    Set OutlookApp = CreateObject("Outlook.Application")

    ' 遍历行循环
    For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)
        email_ = cell.Offset(1, 4).Value
        email2_ = cell.Offset(1, 5).Value
        cc = cell.Offset(1, 6).Value
        subject_ = cell.Offset(1, 7).Value
        path_ = cell.Offset(1, 8).Value
        
        ' 读取附件Excel的表格内容转HTML
        If Dir(path_) <> "" Then ' 先判断文件存在
            Set wb = Workbooks.Open(path_, ReadOnly:=True)
            Set ws = wb.Sheets(1) ' 读取第一个工作表，可按需修改序号
            Set rng = ws.UsedRange ' 读取全部已使用区域，可按需改为固定范围
            tableHtml = RangeToHTML(rng)
            wb.Close SaveChanges:=False
            Set wb = Nothing
            Set ws = Nothing
            Set rng = Nothing
        Else
            tableHtml = "<p><i>未找到对应附件文件</i></p>"
        End If

        ' 创建邮件并发送
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_ & ";" & email2_
            .cc = cc
            .Subject = subject_
            .htmlbody = "Dear All,<br><br>" _
                    & "Please find updated statement of accounts for your reference and payment persual.<br><br>" _
                    & tableHtml _ ' 插入转换好的表格HTML
                    & "<br>Kindly review all Line items and confirm payments whichs needs to be settled before the end of the month.<br><br>" _
                    & "Kindly feedback on status of past due invoice and do let me know shall you require anything else.<br><br><br>" _
                    & "Thanks and Regards,<br>" _
                    & "XXXXX<br>" _
                    & "XXXXX,<br>" _
                    & "XXXXX<br>" _
                    & "XXXXX<br>" _
                    & "XXXXX<br>" _
                    & "XXXXX<br>"
            .Attachments.Add path_
            .DeleteAfterSubmit = False
            .Send
        End With
    Next
    ' 释放对象
    Set OutlookApp = Nothing
    Set MItem = Nothing
End Sub

' 自定义函数：将Excel范围转换为带原格式的HTML代码
Function RangeToHTML(rng As Range) As String
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    ' 复制范围到临时工作簿
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    ' 发布为HTML文件
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    ' 读取HTML文件内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.ReadAll
    ts.Close
    RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    ' 清理临时文件和对象
    TempWB.Close SaveChanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

调整说明 #

• 新增了附件读取逻辑：获取到路径后自动以只读模式打开对应Excel文件，不会修改原附件内容
• 新增的RangeToHTML函数可保留表格原有的单元格格式、边框、颜色等样式，无需额外调整格式
• 表格默认插入在正文说明文字与落款之间，你可以按需调整HTML拼接的位置
• 增加了文件存在性判断，避免路径错误导致宏崩溃
• 新增了对象释放逻辑，不会在后台残留Excel进程

使用注意 #

• 如果附件Excel有多个工作表，修改Set ws = wb.Sheets(1)里的序号即可指定读取的工作表
• 如果不需要读取全部已使用区域，将Set rng = ws.UsedRange替换为固定范围即可，例如Set rng = ws.Range("A1:F20")

内容的提问来源于stack exchange，提问作者Jenita Kurlawala