將 Excel 范圍發布為 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

• 樹屋而不是樹屋

如您所見，這是因為文本會超出表格范圍的邊界。

謝謝你的幫助。 最大限度

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 表格數據/單元格中，您可以在保存為 html 文件之前使用.AutoFit使列寬與單元格中的文本長度匹配。

這將確保 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