将Excel Range发布到HTML时文本被截断

Question

为使某些业务流程自动化，我正在将Excel单元格范围复制到Outlook邮件中。我使用HTML方法将范围插入到邮件正文中。但是，范围的顶部是带有清晰边界的“正常”表。表格下方有一些自由文本（在开始处写入1个单元格）。

如果自由文本的长度超出表的范围，则该文本将被剪切并且不显示。

有解决方法吗？

在代码的附加部分中找到生成HTML文件（并剪切文本）的代码部分。以及用于说明的屏幕截图。

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


'Publish the sheet to a htm file
'Until here Text is displayed correctly. 
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

文本文件的最后两个单词应显示：

• 足球而不是footba

• 树屋，而不是treeho

如您所见，这是由于文本超出了表格范围的边界。

感谢您的帮助。最高

Answer 1

这是一个功能，它将修剪一行文本以适合指定的宽度：

Function TrimTextToWidth(Text As String, Width As Double) As String
    'We need to put the Text into a Shape to measure the width
    'You may need to change the Font Formatting of the Shape to match your cell
    With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 10 * (Len(Text) + 1), (30 * (1 + Len(Text) - Len(Replace(Text, vbLf, "")))))
        .TextFrame2.TextRange.Text = Text
        'Trim the text until it fits within the width
        While (.TextFrame2.TextRange.Characters.BoundWidth > Width) And Len(.TextFrame2.TextRange.Text) > 0
            .TextFrame2.TextRange.Text = Left(.TextFrame2.TextRange.Text, Len(.TextFrame2.TextRange.Text) - 1)
        Wend
        TrimTextToWidth = .TextFrame2.TextRange.Text
        'Remove the shape when we have finished with it
        .Delete
    End With
End Function

Answer 2

要确保文本不会超出或隐藏在html表数据/单元格中，可以在保存之前使用 .AutoFit 使列宽与单元格中的文本长度匹配作为html文件。

这将确保html表的宽度容纳所有文本。

只需添加以下行： .Cells.EntireColumn.AutoFit

这是代码的更新部分：

With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
.Cells.EntireColumn.AutoFit ' Added line of code to make column widths match the text length
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With