VBA：如何解决发布到htm文件造成的缓慢问题？

我有一些代码，运行时，select一些单元格，删除这些单元格的条件格式，但保持格式，然后将这些单元格转换为HTM，以便他们可以通过电子邮件发送。 我遇到的问题是，将表格发布到htm文件的过程非常缓慢，我有很多电子邮件出来，有没有办法绕过这个缓慢？

代码如下：

Sub EmailExtract() Dim objOutlook As Object Dim objMail As Object Dim TempFilePath As String Dim Location As String Dim PrimaryNumber As String Dim rng As Range Dim PrimaryRecipients As String Dim SecondaryRecipients As String Dim To_Name As String Dim Region As String Worksheets("Contacts").Activate Range("A2").Select While ActiveCell <> "" Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) ActiveCell.Offset(1, 0).Select PrimaryNumber = ActiveCell.Value To_Name = ActiveCell.Offset(0, 4).Value If To_Name = "" Or To_Name = "0" Then To_Name = ActiveCell.Offset(0, 7).Value If To_Name = "" Or To_Name = "0" Then MsgBox PrimaryNumber & " does not have a Manager with a first name." Exit Sub Else PrimaryRecipients = ActiveCell.Offset(0, 9).Value SecondaryRecipients = ActiveCell.Offset(0, 10).Value End If Else PrimaryRecipients = ActiveCell.Offset(0, 6).Value SecondaryRecipients = ActiveCell.Offset(0, 9).Value & ";" & ActiveCell.Offset(0, 10).Value End If Worksheets("Retailer Output 2").Activate Range("C2").Value = PrimaryNumber ActiveWorkbook.Worksheets("Retailer Output 2").Copy _ after:=ActiveWorkbook.Worksheets("Retailer Output 2") ActiveSheet.Name = "Without Formatting" Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible) If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If Keep_Format With objMail .To = PrimaryRecipients .Cc = SecondaryRecipients .Subject = "" Dim Greeting As String If Time >= #12:00:00 PM# Then Greeting = "Afternoon" Else Greeting = "Morning" End If Dim LastMonth As String LastMonth = MonthName((Month(Date)) - 1) .HTMLBODY = "<font face=Arial><p>" & "Good " & Greeting & " " & To_Name & "," & "</p>" .HTMLBODY = .HTMLBODY + "<p>" & "Please find below your " & LastMonth & " Information." & "</p>" .HTMLBODY = .HTMLBODY + RangetoHTML(rng) .Send End With Worksheets("Contacts").Activate Application.DisplayAlerts = False Sheets("Without Formatting").Delete Application.DisplayAlerts = True Wend Set objOutlook = Nothing Set objMail = Nothing Set objOutlook = Nothing Set objMail = Nothing End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2013 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook 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 rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) rng.Copy Destination:=.Cells(1) .Cells(1).Select 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, -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 Function Keep_Format() Dim ws As Worksheet Dim mySel As Range, aCell As Range '~~> Change this to the relevant sheet Set ws = ThisWorkbook.Sheets("Without Formatting") '~~> Change this to the relevant range Set mySel = ws.Range("A1:M28") For Each aCell In mySel With aCell .Font.FontStyle = .DisplayFormat.Font.FontStyle .Interior.Color = .DisplayFormat.Interior.Color .Font.Strikethrough = .DisplayFormat.Font.Strikethrough End With Next aCell mySel.FormatConditions.Delete End Function 

我相信（使用debugging器的结果），问题是以下几行：

  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 

有人可以帮帮我吗？