Руками вставить диаграмму в письмо Outlook более чем просто: копируем нужную диаграмму, переходим в письмо и вставляем в нужное место. Через VBA это делается чуть сложнее...
Я уже писал несколько статей по работе в Outlook, среди которых есть и Вставить в письмо Outlook таблицу Excel с форматированием. Однако, код вставки таблицы не совсем подходит для вставки диаграммы. Первый код из статьи, в котором используется метод SendKeys для вставки в тело письма объекта из буфера обмена(будь то диапазон, фигура или диаграмма), хоть и сработает, не очень мне нравится. Он не очень надежен. Почему? Например поэтому: При вставке из VBA картинки на лист ошибка Метод paste из класса worksheet завершен неверно. А есть еще причины: на некоторых ПК сочетание клавиш
'--------------------------------------------------------------------------------------- ' Author : The_Prist(Щербаков Дмитрий) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872 ' Purpose: Процедура создает письмо в Outlook ' и вставляет в него выделенную на листе диаграмму методом "посыла" команды "Вставить" '--------------------------------------------------------------------------------------- Sub SendMail_WithChart_SendKeys() Dim objOutlookApp As Object, objMail As Object Application.ScreenUpdating = False 'копируем выделенную диаграмму Selection.Copy On Error Resume Next 'пробуем подключиться к Outlook Set objOutlookApp = CreateObject("Outlook.Application") 'создаем новое сообщение Set objMail = objOutlookApp.CreateItem(0) 'при подключении к Outlook или при создании письма произошла ошибка 'завершаем работу кода If Err.Number <> 0 Then Set objOutlookApp = Nothing Set objMail = Nothing Exit Sub End If On Error GoTo 0 'задаем параметры созданного сообщения With objMail .To = "адрес получателя" .Subject = "Тема: вставка в письмо диаграммы" .BodyFormat = 2 'olFormatHTML - формат HTML .Display 'отображаем сообщение 'передаем управление ОС, чтобы завершились все лишние процессы DoEvents 'посылаем команду нажатия клавиш Ctrl+V для вставки диаграммы из буфера обмена Application.SendKeys "^v" DoEvents '.Send 'если надо сразу отправить письмо End With Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub |
Перед запуском кода необходимо сначала выделить на листе нужную диаграмму.
Однако я сторонник методов более надежных, пусть и более сложных. И если есть возможность сделать код, который будет работать более стабильно, то буду использовать именно его. Путь приведенный ниже метод не универсален и работает только с диаграммами - он более надежен, чем код выше. По сути метод основан на встроенной возможности сохранения диаграмм в файл на диске(метод
'--------------------------------------------------------------------------------------- ' Author : The_Prist(Щербаков Дмитрий) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872 ' Purpose: Процедура создает письмо в Outlook ' и вставляет в него выделенную на листе диаграмму как картинку '--------------------------------------------------------------------------------------- Sub SendMail_WithChartAsPicture() Dim objOutlookApp As Object, objMail As Object Dim oChart As Chart Dim sChartPath As String, sPictureBodyCode As String Application.ScreenUpdating = False 'копируем выделенную диаграмму On Error Resume Next Set oChart = ActiveChart If oChart Is Nothing Then MsgBox "Необходимо выделить диаграмму", vbInformation, "www.excel-vba.ru" Exit Sub End If 'путь для сохранения диаграммы на диске(необходим для дальнейшей вставки в письмо) sChartPath = ThisWorkbook.Path & "\chart.png" 'сохраняем диаграмму как картинку PNG на диск oChart.Export sChartPath, "PNG" 'создаем код для вставки диаграммы в письмо sPictureBodyCode = "<img src=cid:" & Replace(Dir(sChartPath, 16), " ", "%20") & ">" ' & " height=240 width=180>" '" height=240 width=180>" - если нужны конкретные размеры вставляемой картинки 'пробуем подключиться к Outlook Set objOutlookApp = CreateObject("Outlook.Application") 'создаем новое сообщение Set objMail = objOutlookApp.CreateItem(0) 'при подключении к Outlook или при создании письма произошла ошибка 'завершаем работу кода If Err.Number <> 0 Then Set objOutlookApp = Nothing Set objMail = Nothing Exit Sub End If On Error GoTo 0 'задаем параметры созданного сообщения With objMail .To = "адрес получателя" .Subject = "Тема: вставка в письмо диаграммы" .BodyFormat = 2 'olFormatHTML - формат HTML .Attachments.Add sChartPath .Display 'отображаем сообщение 'передаем управление ОС, чтобы завершились все лишние процессы DoEvents 'теперь добавляем диаграмму .HTMLBody = sPictureBodyCode & "<p>" & .HTMLBody '.Send 'если надо сразу отправить письмо End With 'удаляем временную картинку диаграммы с диска Kill sChartPath Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub |
Так же как и в случае с предыдущим кодом, необходимо сначала выделить на листе нужную диаграмму и запустить код.
Но я прекрасно понимаю, что на листе может быть более одной диаграммы и все их надо вставить на лист. Даже не так: не все, а несколько выделенных. Предыдущий код не сможет этого сделать, т.к. изначально работает только с одной диаграммой и подстроить его под одну-две-три простой правкой двух строк кода не получится. Поэтому я приведу ниже код, который вставляет в письмо все выделенные диаграммы(а перед ними добавит текст):
'--------------------------------------------------------------------------------------- ' Author : The_Prist(Щербаков Дмитрий) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872 ' Purpose: Процедура создаем письмо в Outlook ' и вставляет в него все выделенные на листе диаграммы как картинки '--------------------------------------------------------------------------------------- Sub SendMail_WithSelectedCharts() Dim objOutlookApp As Object, objMail As Object Dim oChart, sSelR As ShapeRange Dim aCharts(), asChartPath(), spath, sChartPath As String, sPictureBodyCode As String Dim lc_cnt As Long On Error Resume Next 'пробуем определить все выделенные диаграммы Set sSelR = Selection.ShapeRange If Not sSelR Is Nothing Then 'цикл по всем выделенным диаграммам For Each oChart In sSelR If oChart.Type = msoChart Then ReDim Preserve aCharts(lc_cnt) Set aCharts(lc_cnt) = oChart 'увеличиваем счетчик массива lc_cnt = lc_cnt + 1 End If Next 'выделена только одна диаграмма, для неё нет объекта ShapeRange 'используем ActiveChart Else ReDim aCharts(0) Set aCharts(0) = ActiveChart If Not aCharts(0) Is Nothing Then lc_cnt = lc_cnt + 1 End If End If On Error GoTo 0 If lc_cnt = 0 Then MsgBox "Не выбрано ни одной диаграммы", vbInformation, "www.excel-vba.ru" Exit Sub End If 'создаем массив для сохранения путей к временным картинкам ReDim asChartPath(lc_cnt - 1) lc_cnt = 0 'отключаем обновление экрана Application.ScreenUpdating = False For Each oChart In aCharts 'создаем путь к картинке sChartPath = ThisWorkbook.Path & "\chart_" & lc_cnt & ".png" 'сохраняем диаграмму как картинку PNG на диск oChart.Chart.Export sChartPath, "PNG" 'создаем код для вставки диаграмм в письмо sPictureBodyCode = sPictureBodyCode & "<img src=cid:" & Replace(Dir(sChartPath, 16), " ", "%20") & "><p>" 'запоминаем все пути созданных картинок(чтобы потом удалить из папки, куда их сохранили) asChartPath(lc_cnt) = sChartPath 'увеличиваем счетчик массива lc_cnt = lc_cnt + 1 Next On Error Resume Next 'пробуем подключиться к Outlook Set objOutlookApp = CreateObject("Outlook.Application") 'создаем новое сообщение Set objMail = objOutlookApp.CreateItem(0) 'при подключении к Outlook или при создании письма произошла ошибка 'завершаем работу кода If Err.Number <> 0 Then Set objOutlookApp = Nothing Set objMail = Nothing Application.ScreenUpdating = True Exit Sub End If On Error GoTo 0 'задаем параметры созданного сообщения With objMail .To = "адрес получателя" .Subject = "Тема: вставка в письмо диаграммы" .BodyFormat = 2 'olFormatHTML - формат HTML 'добавляем все созданные диаграммы в письмо For Each spath In asChartPath .Attachments.Add spath Next .Display 'отображаем сообщение 'передаем управление ОС, чтобы завершились все лишние процессы DoEvents 'теперь добавляем диаграммы(а перед ними текст) .HTMLBody = "Отчет по прибыли: <p>" & sPictureBodyCode & "<p>" & .HTMLBody '.Send 'если надо сразу отправить письмо End With Set objOutlookApp = Nothing: Set objMail = Nothing 'удаляем временные картинки диаграмм с диска For Each spath In asChartPath Kill spath Next Application.ScreenUpdating = True End Sub |
Все, что требуется, это выделить нужные диаграммы на листе и запустить код.
Так же см.:
Как отправить письмо из Excel?
Вставить в письмо подпись из Outlook через VBA
Вставить в письмо Outlook таблицу Excel с форматированием
Сохранить вложения из Outlook в указанную папку
Как отправить письмо от другой учетной записи Outlook