VBA邮件自动化问题：如何在同一邮件插入Excel表格与文本框图片

问题说明 #

我尝试用VBA自动生成包含Excel内容的邮件，目前已成功添加问候语和表格，但带批注的文本框因为非HTML格式无法正常显示。现在运行代码时，原有的表格和问候语会被删除，邮件里只剩文本框的图片。需要把文本框转成图片后，和问候语、表格一起插入同一封邮件，还要保留文本框的字体格式。

问题根源 #

原代码存在逻辑冲突：先通过.HTMLBody设置包含问候语和表格的内容，接着用WordEditor粘贴图片，之后又重新给.HTMLBody赋值添加结尾语，这会直接覆盖之前通过WordEditor插入的图片，同时破坏原有HTML内容的结构。

修改后的代码 #

Sub SendEmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim recipient As String
    Dim ccList As String
    Dim subject As String
    Dim body As String
    Dim parite As String
    Dim i As Integer
    Dim wdDoc As Object ' Word文档对象，用于编辑邮件内容
    
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 获取收件人邮箱
    recipient = Trim(ws.Range("I6").Value)
    
    ' 获取抄送列表
    For i = 7 To 12
        If Trim(ws.Cells(i, "I").Value) <> "" Then
            ccList = ccList & Trim(ws.Cells(i, "I").Value) & ";"
        End If
    Next i
    
    ' 移除抄送列表末尾的分号
    If Right(ccList, 1) = ";" Then
        ccList = Left(ccList, Len(ccList) - 1)
    End If
    
    ' 获取邮件主题
    subject = ws.Range("I4").Value
    
    ' 获取汇率值
    parite = ws.Range("I14").Value
    
    ' 构建邮件HTML主体内容
    body = "<p>Bonjour,</p>" & _
           "<p></p>" & _
           "<p>Suite à votre demande, nous vous prions de trouver ci-après notre proposition de couverture sur la base d’une parité EURUSD " & parite & "</p>"
    
    ' 创建Outlook应用
    Set OutApp = CreateObject("Outlook.Application")
    ' 创建新邮件
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = recipient
        .CC = ccList
        .subject = subject
        
        ' 先加载HTML内容到邮件
        .HTMLBody = body & RangetoHTML(ws.Range("A1:D23")) & "<br><br>"
        
        ' 获取Word编辑器对象，用于插入图片
        Set wdDoc = .GetInspector.WordEditor
        
        ' 将光标定位到HTML内容的末尾
        wdDoc.Range(wdDoc.Content.End - 1, wdDoc.Content.End - 1).Select
        
        ' 复制文本框为图片并粘贴到邮件
        ws.Shapes("TextBox 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        wdDoc.Application.Selection.Paste
        
        ' 在图片后添加结尾问候语
        wdDoc.Range(wdDoc.Content.End, wdDoc.Content.End).InsertAfter "<br><br>Cordialement,"
        
        .Display ' 改为.Send可自动发送邮件
    End With
    
    ' 清理对象
    Set wdDoc = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range) As String
    ' 将Excel区域转换为HTML格式
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim rngCopy As Range
    Dim rowCounter As Long
    Dim colCounter As Long
    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hasData As Boolean

    ' 初始化范围边界
    startRow = rng.Rows.Count
    startCol = rng.Columns.Count
    endRow = 1
    endCol = 1

    ' 确定有数据的行范围
    For rowCounter = 1 To rng.Rows.Count
        hasData = False
        For colCounter = 1 To rng.Columns.Count
            If Not IsEmpty(rng.Cells(rowCounter, colCounter)) Then
                hasData = True
                Exit For
            End If
        Next colCounter
        If hasData Then
            If rowCounter < startRow Then startRow = rowCounter
            If rowCounter > endRow Then endRow = rowCounter
        End If
    Next rowCounter

    ' 确定有数据的列范围
    For colCounter = 1 To rng.Columns.Count
        hasData = False
        For rowCounter = 1 To rng.Rows.Count
            If Not IsEmpty(rng.Cells(rowCounter, colCounter)) Then
                hasData = True
                Exit For
            End If
        Next rowCounter
        If hasData Then
            If colCounter < startCol Then startCol = colCounter
            If colCounter > endCol Then endCol = colCounter
        End If
    Next colCounter

    ' 创建排除空单元格的新范围
    Set rngCopy = Nothing
    For rowCounter = startRow To endRow
        For colCounter = startCol To endCol
            If Not IsEmpty(rng.Cells(rowCounter, colCounter)) Then
                If rngCopy Is Nothing Then
                    Set rngCopy = rng.Cells(rowCounter, colCounter)
                Else
                    Set rngCopy = Union(rngCopy, rng.Cells(rowCounter, colCounter))
                End If
            End If
        Next colCounter
    Next rowCounter

    ' 如果范围无数据，返回空字符串
    If rngCopy Is Nothing Then
        RangetoHTML = ""
        Exit Function
    End If

    ' 将范围转换为HTML文件
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rngCopy.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 ' 粘贴列宽
        .Cells(1).PasteSpecial xlPasteValues ' 粘贴值
        .Cells(1).PasteSpecial xlPasteFormats ' 粘贴格式
        Application.CutCopyMode = False
        On Error Resume Next
        .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

关键修改点 #

• 引入wdDoc对象统一管理邮件内容，避免直接赋值.HTMLBody导致的内容覆盖
• 粘贴图片前将光标定位到现有HTML内容的末尾，确保图片插入在表格之后
• 通过Word编辑器的InsertAfter方法添加结尾问候语，保证内容顺序正确
• 保留了文本框转图片的逻辑，确保字体格式完整保留

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