读取额外行中的VBA TextStream对象结果

Question

读取额外行中的VBA TextStream对象结果

ksc*_*ndl 8 excel outlook vba object excel-vba

使用Ron de Bruin 的RangeToHTML函数,我将一个范围粘贴到Outlook电子邮件中.但是,似乎正在将一个额外的空白行粘贴到电子邮件中,如下所示:

我已经确认该Source:=TempWB.Sheets(1).UsedRange.Address行正确地只抓取数据本身而不是额外的行.我也确认输入范围RangetoHTML()也是正确的.我唯一的猜测是该.ReadAll方法以某种方式在文件中添加了一行,但我不知道如何调试它.这是RangetoHTML我正在使用的功能,以便于参考:

Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False

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

'Copy the range and create a new workbook to past the data in
If rng Is Nothing Then GoTo Skip

rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1, 2).PasteSpecial Paste:=8
    .Cells(1, 2).PasteSpecial xlPasteFormats
    .Cells(1, 2).PasteSpecial xlPasteValues
    .Cells.Font.Name = "Calibri"
    .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
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)
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

Skip:

Application.ScreenUpdating = True
End Function

Run Code Online (Sandbox Code Playgroud)

编辑:这是生成电子邮件的代码部分.这RangeToHTML(rng_Summary)是将范围插入电子邮件的内容:

'Construct the actual email in outlook
With OutMail
    .to = "LastName, FirstName"
    .CC = ""
    .BCC = ""
    .Subject = "LOB Break Status (As of " & Format(Now(), "m/d") & ")"
    .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>Here is the latest status for the breaks, by product, in the LOB:" & _
                RangetoHTML(rng_Summary) & _
                "<BODY style=font-size:9pt;font-family:Calibri>*allows are excluded from Avg. Age of Breaks calculation" & _
                "<ul>" & _
                    "<li>" & _
                        "<BODY style=font-size:11pt;font-family:Calibri><u><b>Average Age of Breaks</u></b>" & Chr(150) & " " & avg_age_change & " from " & avg_break_age_prev & " to " & avg_break_age_curr & " due to ________" & _
                    "</li>" & _
                "</ul>"
    .Display 'CHANGE THIS to .Display/.Send if you want to test/send
End With

Run Code Online (Sandbox Code Playgroud)

Answer 1

小智 2

Workbook.PublishObjects包括一个额外的行来强制列宽。

 <![if supportMisalignedColumns]>
 <tr height=0 style='display:none'>
  <td width=64 style='width:48pt'></td>
  <td width=64 style='width:48pt'></td>
 </tr>
 <![endif]>

Run Code Online (Sandbox Code Playgroud)

使用@EngineerToast的答案“ 仅替换VBA中字符串中最后一次出现的匹配”，我们可以隐藏最后一行，同时保留列宽度。

Function getTrimRangetoHTML(rng As Range) As String
    Const OldText = "display:none"
    Const NewText = "visibility: hidden;"
    Dim s As String
    s = RangetoHTML(rng)
    s = StrReverse(Replace(StrReverse(s), StrReverse(OldText), StrReverse(NewText), , 1))
    getTrimRangetoHTML = s

    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText s
        .PutInClipboard
    End With
End Function

Run Code Online (Sandbox Code Playgroud)

附录

在查看 RangetoHTML 的输出后，我注意到第一行还强制执行列宽。尽管如此， getTrimRangetoHTML 将给出隐藏最后一行的所需结果。

归档时间：	8 年，5 月前
查看次数：	572 次
最近记录：	8 年，3 月前