在Outlook电子邮件中粘贴Excel表格：它回头看

我已经能够运行以下代码将Excel范围复制到Outlook电子邮件中（使用Ron de Bruin提供的代码：

Sub SendEMail(SheetName As String, EmailBody As String, EmailSubject As String, MyAttachment As String) ' You need to use this module with the RangetoHTML subroutine. ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. Dim rng As Range Dim OutApp As Object Dim OutMail As Object Set rng = Nothing On Error Resume Next ' Only send the visible cells in the selection. ActiveSheet.Unprotect Set rng = ActiveSheet.Range(EmailBody).SpecialCells(xlCellTypeVisible) ' You can also use a range with the following statement. ' Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible) On Error GoTo 0 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 With Application .EnableEvents = False .ScreenUpdating = False End With Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail '.To = "[e-mail]" '.CC = "" '.BCC = "" .subject = "Resumen de " & EmailSubject .htmlbody = RangetoHTML(rng) ' In place of the following statement, you can use ".Display" to ' display the e-mail message. .Display End With On Error GoTo 0 With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing ActiveSheet.Protect End Sub 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 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) '.Cells(1).PasteSpecial Paste:=8 '.Cells(1).PasteSpecial xlPasteValues, , False, False '.Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).PasteSpecial xlPasteAll .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, -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 

它发送正常，但问题是打开时。 这个表格对读者来说太宽了

有什么可以做的纠正这一点，并有相同的宽度在Excel列？

谢谢

Answer 1

我认为代码有点复杂，用这个代码只能在邮件中插入所选范围的值…
如果你想添加列的宽度，你可以添加代码：

 With TempWB.Sheets(1) .Cells(1).PasteSpecial xlPasteAll .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With ' Code ADDED i = 1 For Each xx In rng.Columns TempWB.Sheets(1).Columns(i).ColumnWidth = xx.ColumnWidth i = i + 1 Next ' Code ADDED '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 

两块之间只有5条连线。 该代码在新工作表（临时工作表）中设置原始宽度。
对我来说，最简单的方法是直接在邮件的HTMLBody中复制和粘贴范围。 在这种情况下，你有所有的表格格式（例如：颜色，高度，字体…）。 要做到这一点的代码可以是：

  Set mailApp = CreateObject("Outlook.Application") Set mail = mailApp.CreateItem(olMailItem) mail.Display mail.To = "[e-mail]" mail.Subject = "subject" & Now Dim Clip As MSForms.DataObject Set Clip = New MSForms.DataObject Clip.SetText ("test ... body" & vbNewLine & vbNewLine _ & "this is another line " & vbCrLf _ & "this is another line again " & vbNewLine & " ") Clip.PutInClipboard Set wEditor = mailApp.ActiveInspector.wordEditor wEditor.Application.Selection.Paste Selection.Copy wEditor.Application.Selection.Paste ' mail.send