Excel VBA - 复制包括图像的选定单元格

Question

我有一个vba脚本，它复制选定的单元格区域并将其粘贴到电子邮件正文中。在选定的单元格范围内是我公司徽标的图像。除了图像，一切都很好地复制和粘贴。 我需要对图像本身做些什么，可能将其“嵌入”到工作表中，以便与单元格一起复制？ 或者我在vba脚本中需要做些什么来将图像与单元格一起复制？

以下是完整代码：

Sub copyObjects()
  Dim IsCreated As Boolean
  Dim PdfFile As String, Title As String, signature As String
  Dim OutlApp As Object
  Dim RngCopied As Range

Set RngCopied = Selection

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
  Set OutlApp = CreateObject("Outlook.Application")
  IsCreated = True
End If
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

 .Display         ' We need to display email first for signature to be added
 .Subject = Title
 .To = ActiveSheet.Range("E10").Value ' <-- Put email of the recipient here or use a cell value
 .CC = "whoever@abc.com; copy@abc.com" ' <-- Put email of 'copy to' recipients here
 .HTMLBody = "Thank you for the opportunity to bid on the painting for " & ActiveSheet.Range("B9").Value & ". " & " Please read our attached proposal in it's entirety to be sure of all inclusions, exclusions, and products proposed.  Give us a call with any questions or concerns." & _
    vbNewLine & vbNewLine & _
    RangetoHTML(RngCopied) & _
    "Thank you," & _
    .HTMLBody      ' Adds default outlook account signature



On Error Resume Next


' Return focus to Excel's window
Application.Visible = True
If Err Then
  MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
' Note: sometimes Outlook object can't be released from the memory
Set OutlApp = Nothing
End Sub


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

集

Application.CopyObjectsWithCells = True

复制前

Answer 2

如果它有帮助，我会把它放在像这样的宏中......

宏将上述选项卡复制到新工作簿中，每个选项卡包含图表和数据单元格以及宏按钮 CopyObjects行确保每个选项卡上的所有数据都包含在副本中。没有它，您可能会发现排除了图表和其他绘制对象。

警告，我即将发布有关此命令的问题。由于一些奇怪的原因，只有一个图表标签没有被复制 - 非常奇怪所以，请注意 - 检查它是否适合您。

尼克