vba 将范围从 Excel 复制到 Outlook 时如何保留格式

How to keep formats when I copy a range from Excel to outlook

提问by Jonathan Raul Tapia Lopez

Hello i have an Excel table with some formats 10(Red)-> 15(Green), but at the end I loose all the formats i have in my excel. I use the next code to send and email from a range to outlook

您好，我有一个 Excel 表格，其中包含一些格式10(Red)-> 15(Green)，但最后我丢失了我的 excel 中的所有格式。我使用下一个代码从一个范围发送和电子邮件到 Outlook

Sub email()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Fname As String
    Dim hoja As String
    Dim rng As Range
    Dim celdas As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set rng = Range("C3:Q22")
    On Error Resume Next
    With OutMail

        .To = "juan"
        .CC = "Maria"
        .BCC = ""
        .Subject = "XXXX"
        .HTMLBody = "Hey" & RangetoHTML(rng)

        .Display   'or use .Display
    End With
    On Error GoTo 0

    'Kill Fname
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

and the next function, I copied from the next link How to send mails from excel

和下一个功能，我从下一个链接复制如何从 excel 发送邮件

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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).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

采纳答案by Jonathan Raul Tapia Lopez

Ok I found how to made it, in rangetoHtml(), when is pasting the values I changed the code for:

好的，我在 rangetoHtml() 中找到了如何制作它，粘贴值时我更改了以下代码：

    With TempWB.Sheets(1)
        '.Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial
        '.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

Becase If I made just a copy and paste I dont lost any format.

因为如果我只是复制和粘贴，我不会丢失任何格式。

回答by Jonathan Porter

While OP's accepted answer may have worked for him, I don't believe it's the right answer.

虽然 OP 接受的答案可能对他有用，但我认为这不是正确的答案。

If you want to keep the formatting from your source you need to use xlPasteAllUsingSourceTheme

如果您想从源中保留格式，则需要使用xlPasteAllUsingSourceTheme

Code:

代码：

With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        '.Cells(1).PasteSpecial xlPasteValues, , False, False
        '.Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
End With