将Excel范围粘贴到Outlook电子邮件正文

Posted 2021-05-03

我想在Excel工作表中复制固定范围内的数据并粘贴到电子邮件正文中。

以下是我提出的代码。但是我无法粘贴指定范围A11：H12。

Private Sub CommandButton1_Click()
    On Error GoTo ErrHandler

' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

With objEmail
    .To = "email"
    .Subject = "test"
    .Body = ActiveSheet.Range("A11:H12").Select
    .Display        ' DISPLAY MESSAGE.
End With

' CLEAR.
Set objEmail = Nothing:    Set objOutlook = Nothing

ErrHandler:
    '
End Sub

答案

正如Ron在评论中所说的那样。波纹管代码和功能可以解决问题。复制它们

Private Sub CommandButton1_Click()

' SET Outlook APPLICATION OBJECT.
Dim rng As Range
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

Set rng = Nothing
On Error Resume Next
Set rng = ActiveSheet.Range("A11:H12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

With objEmail
.To = "email"
.Subject = "test"
.htmlBody = RangetoHTML(rng)
.Display        ' DISPLAY MESSAGE.
End With

' CLEAR.
Set objEmail = Nothing:
Set objOutlook = Nothing

End Sub

---

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

另一答案

码：

    Sub sendEmail()
    'call outlook
    Dim MyOlapp As Object, MyItem As Object
    Set MyOlapp = CreateObject("Outlook.Application")
    Set MyItem = MyOlapp.CreateItem(olMailItem)
        'ajust range of sheet
        Range("A11:H12").Select
        Selection.Copy

    With MyItem
        'ajust number of sheet
        .To = Sheet17.[b1].Value 'e-mail adress
        .Subject = Sheet17.[b2].Value 'subject of e-mail
        .Body = Sheet17.[b3].Value 'body of e-mail
        .Display
        SendKeys ("^{DOWN}")
        SendKeys ("^{DOWN}")
        SendKeys ("%m")
        SendKeys ("v")
        SendKeys ("s")
        SendKeys ("{UP}")
        SendKeys ("{UP}")
        SendKeys ("{ENTER}")
        SendKeys ("{ENTER}")
        SendKeys ("%m")
        SendKeys ("q")
        SendKeys ("{ENTER}")


    End With
    End Sub