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's site上的RangetoHTML功能对我来说一直很好。

您是否检查了电子邮件的BodyFormat属性？它可能默认为Rich Text。

Answer 2

替换此行：

.Cells(1).PasteSpecial Paste:=8

使用：

.Cells(1).PasteSpecial Paste:=1

＆安培;删除以下两行：

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

VBA：在电子邮件中复制和粘贴单元格而不会丢失格式

2 个答案: