如何自动将Excel工作表复制到Outlook中

Question

我正在尝试将Excel中的活动Excel工作表范围a1：k49自动复制到Outlook中以作为电子邮件发送。

我还在Excel工作表的顶部有一个徽标，但是当此代码复制到outlook中时，徽标图片不显示。

Sub CovercopypasteOutlook()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set rng = Nothing
    Set rng = ActiveSheet.Range("a1:k49")


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

    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        '.Send
    .display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = 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"

    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

    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

    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=")

    TempWB.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

可能有一种更简单的方法来复制范围并直接粘贴到outlook MailItem，而不使用PublishObject。不要使用上述任何建议

我只想复制工作表的使用范围，然后使用mailItem的WordEditor，如：

'On Error Resume Next  '## GET RID OF THIS UNLESS YOU KNOW WHAT YOU'RE DOING. YOU DON'T.
With OutMail
    .To = ""
    .CC = ""
    .BCC = ""
    .Subject = ""
    'HTMLBody = RangeToHtml(rng)  '### GET RID OF THIS BECAUSE IT IS NOT NEEDED###
    '.Send
.display
End With

'### ^^^ ADD THESE THREE LINES RIGHT BELOW THE LINES ABOVE ^^^ ###
Dim doc As Object
Set doc = OutApp.ActiveInspector.WordEditor
doc.Range(1, 1).Paste
'### END OF ADDED LINES ###

结果：

这不使用你的RangeToHtml函数，所以它不会对你用FSO做的标记格式化，但是这应该足以让你开始，我想。