Как вставить диапазон ячеек в тело сообщения как изображение в Excel?
Если вам нужно скопировать диапазон ячеек и вставить его как изображение в тело сообщения при отправке электронного письма из Excel. Как бы вы справились с этой задачей?
Вставьте диапазон ячеек в тело письма как изображение с кодом VBA в Excel
Вставьте диапазон ячеек в тело письма как изображение с кодом VBA в Excel
Возможно, для вас нет другого хорошего способа решить эту задачу, код VBA в этой статье может вам помочь. Пожалуйста, сделайте так:
1. Включите лист, который вы хотите скопировать, и вставьте ячейки как изображение, удерживая нажатой кнопку ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.
2. Нажмите Вставить > Модулии вставьте следующий код в Модули Окно.
Код VBA: вставьте диапазон ячеек в тело письма как изображение:
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='//cdn.extendoffice.com/cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = " "
.Cc = " "
.Display
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Внимание: В приведенном выше коде вы можете изменить основной текст и адрес электронной почты по своему усмотрению.
3. После ввода кода нажмите F5 нажмите клавишу для запуска этого кода, появится диалоговое окно, напоминающее вам о выборе диапазона данных, который вы хотите вставить в тело письма как изображение, см. снимок экрана:
4. Затем нажмите OK и Сообщение отображается окно, выбранный диапазон данных был вставлен в тело как изображение, см. снимок экрана:
Внимание: В Сообщение В окне «Кому» и «Копия» вы также можете изменить текст сообщения и адреса электронной почты в полях «Кому» и «Копия».
5, Наконец, нажмите Отправить кнопку, чтобы отправить это письмо.
Внимание: Если вам нужно вставить несколько диапазонов из разных листов, приведенный ниже код VBA может оказать вам услугу:
Во-первых, вы должны выбрать несколько диапазонов, которые вы хотите вставить в тело письма как изображения, а затем применить следующий код:
Код VBA: вставьте несколько диапазонов ячеек в тело письма как изображение:
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
Dim xSheet As Worksheet
Dim xAcSheet As Worksheet
Dim xFileName As String
Dim xSrc As String
On Error Resume Next
TempFilePath = Environ$("temp") & "\RangePic\"
If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then
VBA.MkDir TempFilePath
End If
Set xAcSheet = Application.ActiveSheet
For Each xSheet In Application.Worksheets
xSheet.Activate
Set xRg = xSheet.Application.Selection
If xRg.Cells.Count > 1 Then
Call createJpg(xSheet.Name, xRg.Address, "DashboardFile" & VBA.Trim(VBA.Str(xSheet.Index)))
End If
Next
xAcSheet.Activate
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
xSrc = ""
xFileName = Dir(TempFilePath & "*.*")
Do While xFileName <> ""
xSrc = xSrc + VBA.vbCrLf + "<img src='cid:" + xFileName + "'><br>"
xFileName = Dir
If xFileName = "" Then Exit Do
Loop
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& xSrc _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
xFileName = Dir(TempFilePath & "*.*")
Do While xFileName <> ""
.Attachments.Add TempFilePath & xFileName, olByValue
xFileName = Dir
If xFileName = "" Then Exit Do
Loop
.To = " "
.Cc = " "
.Display
End With
If VBA.Dir(TempFilePath & "*.*") <> "" Then
VBA.Kill TempFilePath & "*.*"
End If
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\RangePic\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Лучшие инструменты для офисной работы
Улучшите свои навыки работы с Excel с помощью Kutools for Excel и почувствуйте эффективность, как никогда раньше. Kutools for Excel предлагает более 300 расширенных функций для повышения производительности и экономии времени. Нажмите здесь, чтобы получить функцию, которая вам нужна больше всего...
Вкладка Office: интерфейс с вкладками в Office и упрощение работы
- Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
- Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
- Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!
