Question

我在修改宏时遇到问题，而是复制选定的数据范围并通过电子邮件发送到特定地址。

我从以下工作代码开始：

Sub Mail_Range()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial Paste:=xlPasteValues
    .Cells(1).PasteSpecial Paste:=xlPasteFormats
    .Cells(1).Select
    Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
    'You use Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    'You use Excel 2007-2016
    FileExtStr = ".xlsx": FileFormatNum = 51
End If

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

With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
        .to = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add Dest.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0
    .Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

问题是：

1）如何复制特定范围内的任何图表？

2）如何将复制的范围放在.Body区域？

Answer 1

如果您安装了完整的Office，则可以使用Outlook中的Word编辑器来实现此目的。此Word编辑器可以将复制的Excel范围粘贴为链接的Excel范围或可以使用WdPasteDataType Enumeration指定的多个其他对象。

示例：

拥有活动的Excel表格，如：

这样的代码：

Sub emailer()

 'get Outlook Application
 Dim oOlApp As Object
 On Error Resume Next
 Set oOlApp = GetObject(, "Outlook.Application")
 On Error GoTo 0
 If oOlApp Is Nothing Then
  Set oOlApp = CreateObject("Outlook.Application")
 End If

 olMailItem = 0
 Set oOlMItem = oOlApp.CreateItem(olMailItem)

 'get Excel cell range which shall be in the mail
 Set oWB = ActiveWorkbook
 Set oWS = ActiveWorkbook.Worksheets(1)
 Set oRange = oWS.Range("A1:H17")
 oRange.Copy ' Range is now in Clipboard

 With oOlMItem

  .Display

  .To = "email@email.com"
  .Subject = "Subject"

  Set oOlInsp = .GetInspector
  Set oWdDoc = oOlInsp.WordEditor ' get Word Document from the MailBody

  olFormatRichText = 3
  .BodyFormat = olFormatRichText ' change to RichTextFormat

  Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range
  oWdRng.InsertBefore "This is before the Excel table."
  oWdRng.InsertParagraphAfter
  oWdRng.InsertParagraphAfter

  Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range

  'oWdRng.Paste ' paste Excel range from Clipboard as linked Excel range

  wdInLine = 0
  wdPasteEnhancedMetafile = 9
  wdPasteOLEObject = 0

  'paste Excel range from Clipboad as OLEObject
  oWdRng.PasteSpecial Placement:=wdInLine, DataType:=wdPasteOLEObject
  'paste Excel range from Clipboad as EnhancedMetafile
  'oWdRng.PasteSpecial Placement:=wdInLine, DataType:=wdPasteEnhancedMetafile

  oWdRng.InsertParagraphAfter

  Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range
  oWdRng.InsertBefore "This is after the Excel table."


 End With

 Application.CutCopyMode = False

End Sub

在Outlook中生成此邮件：

发送Excel范围，包括电子邮件图表

1 个答案: