VBA：將單元格復制並粘貼到電子郵件中而不會丟失格式

Question

我希望能夠發送包含Excel電子表格中單元格的電子郵件。 目前，我有以下代碼將想要的范圍插入到電子郵件中，但是我遇到的問題是，它刪除了大多數格式，例如字體更改和某些條件格式已刪除。

Sub EmailExtract()

Dim objOutlook As Object
Dim objMail As Object
Dim TempFilePath As String
Dim Location As String
Dim Individual As String
Dim rng As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Worksheets("Contacts").Activate
Range("A2").Select
While ActiveCell <> ""

    ActiveCell.Offset(1, 0).Select
    Location = ActiveCell.Address
    Individual = ActiveCell.Value
    Worksheets("Individual Output 2").Activate
    Range("C2").Value = Individual

    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



    With objMail
            .To = "joe.bloggs@hotmail.com"
            .Subject = ""

            Dim Greeting As String
            If Time >= #12:00:00 PM# Then
                Greeting = "Afternoon ,"
            Else
                Greeting = "Morning,"
            End If



            .HTMLBODY = "<font face=Arial><p>" & "Good " + Greeting + "</p>"
            .HTMLBODY = .HTMLBODY + "<p>" & "Please find below your " & MonthName((Month(Date)) - 1) & " Information." & "</p>"
            .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
            .HTMLBODY = .HTMLBODY + "<p>" & "Kind Regards" & "</p>"
            .HTMLBODY = .HTMLBODY + "<p>" & "Joe Bloggs" & "</p></font>"
            .Display
    End With
    Worksheets("Contacts").Activate
Wend

Set objOutlook = Nothing
Set objMail = Nothing

Set objOutlook = Nothing
Set objMail = Nothing

End Sub

Function RangetoHTML(rng As Range)

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

我想要的是能夠通過應用格式發送電子郵件摘錄，這可能嗎？ 也許將其作為圖片粘貼到電子郵件中？

Answer 1

Ron de Bruin網站上的RangetoHTML函數對我來說一直很好。

您是否檢查了電子郵件的BodyFormat屬性？ 它可能默認為富文本格式。

Answer 2

替換此行：

.Cells(1).PasteSpecial Paste:=8 

有：

.Cells(1).PasteSpecial Paste:=1

並刪除以下兩行：

.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False