使用RangetoHTML代码复制表格到邮件正文，自动列宽后仍截断文本

问题核心 #

使用Ron de Bruin的RangetoHTML函数将Excel表格导出为HTML并插入Outlook邮件正文时，部分单元格文本被截断：

• 已添加AutoFit自动调整列宽，但问题依然存在
• 手动剪切粘贴邮件中的表格后，文本可完整显示，列宽无变化
• 仅部分列受影响，将列宽扩大45%后问题消失；统一字体后截断问题仍未解决

关键原因分析 #

1. 列宽调整作用对象错误：原代码中列宽放大的循环使用ActiveSheet，但新建的临时工作簿（TempWB）并非当前活动工作表，导致该调整并未实际作用于要导出的表格。
2. Excel与Outlook的渲染差异：Excel的AutoFit基于自身的字符宽度计算，而导出为HTML后，Outlook的HTML渲染引擎对列宽的解析逻辑与Excel存在偏差，需要额外的宽度缓冲。

修改后的RangetoHTML函数 #

Function RangetoHTML(rng As Range)
' By Ron de Bruin, modified to fix text truncation issue
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i As Integer

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

    'Copy the range and create a new workbook to paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 'Paste column widths
        .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
        
        'AutoFit columns first
        .Cells.EntireColumn.AutoFit
        
        'Add buffer to column widths (adjust multiplier as needed)
        For i = 1 To .UsedRange.Columns.Count
            .Columns(i).ColumnWidth = .Columns(i).ColumnWidth * 1.15 'Moderate buffer instead of 45%
        Next i
        
        'Force uniform font to avoid rendering discrepancies
        .Cells.Font.Name = "Calibri"
        .Cells.Font.Size = 11
    End With

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

修改后的SendEmail代码（补全未初始化对象） #

Sub SendEmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh2 As Worksheet, rng As Range
    Dim EmailTo As String, CC As String, Subject As String, strbody As String

    'Initialize worksheet and range - adjust sheet name and range address as needed
    Set sh2 = ThisWorkbook.Sheets("Sheet2")
    Set rng = sh2.Range("A1:E20") 'Replace with your target range

    EmailTo = sh2.Range("B2").Value
    CC = sh2.Range("B3").Value
    Subject = sh2.Range("B5").Value
    'Fix HTML body style syntax errors
    strbody = "<body style='font-family: Calibri; font-size: 14.5pt; line-height: 1;'>" & sh2.Range("B7").Value & "</body>"

    On Error Resume Next
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = EmailTo
        .CC = CC
        .Subject = Subject
        .HTMLBody = strbody & RangetoHTML(rng)
        .Attachments.Add ActiveWorkbook.FullName
        .Display 'or use .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

关键改动说明 #

1. 修正列宽调整的作用对象：将列宽放大的循环移至TempWB.Sheets(1)的With块内，确保调整应用在要导出的临时表格上。
2. 降低宽度缓冲比例：将原45%的放大比例调整为15%，在解决截断问题的同时避免列宽过大；可根据实际文本长度微调该值。
3. 强制统一字体：在临时表格中明确设置字体为Calibri 11号，消除Excel格式粘贴可能带来的字体差异，避免渲染时的宽度计算误差。
4. 修复SendEmail代码的语法与初始化问题：补全sh2和rng的初始化，修正HTML body的样式语法错误（原代码引号嵌套错误）。

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