1
У меня есть скрипт vba, который копирует выбранный диапазон ячеек и вставляет его в тело письма. В пределах выбранного диапазона ячеек - образ логотипа моей компании. Все копии и пасты отлично, за исключением изображения. Есть ли что-то, что мне нужно сделать для самого изображения, возможно, «встроить» его в рабочий лист, чтобы он копировал вместе с ячейками? Или есть что-то, что мне нужно сделать в скрипте vba, чтобы скопировать изображение вместе с ячейками?Excel 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 = "[email protected]; [email protected]" ' <-- 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
Пожалуйста, не используйте [** макросы ** тег] (http://stackoverflow.com/tags/macros/info) для MS Office/VBA. –
Почему бы и нет? Этот код создан из созданной мной макрокоманды. Я назначил макрос, содержащий этот код, в меню правой кнопки мыши. Как насчет помощи с решением! –
Поскольку тэг [macros] зарезервирован для других значений в мире программирования. Вики-файлы специально указывают, что он не должен использоваться для MS Office/VBA, и вместо этого вы должны использовать [vba] или тег приложения [excel-vba]. –