Руками вставить диаграмму в письмо Outlook более чем просто: копируем нужную диаграмму, переходим в письмо и вставляем в нужное место. Через VBA это делается чуть сложнее...
Я уже писал несколько статей по работе в Outlook, среди которых есть и Вставить в письмо Outlook таблицу Excel с форматированием. Однако, код вставки таблицы не совсем подходит для вставки диаграммы. Первый код из статьи, в котором используется метод SendKeys для вставки в тело письма объекта из буфера обмена(будь то диапазон, фигура или диаграмма), хоть и сработает, не очень мне нравится. Он не очень надежен. Почему? Например поэтому: При вставке из VBA картинки на лист ошибка Метод paste из класса worksheet завершен неверно. А есть еще причины: на некоторых ПК сочетание клавиш Ctrl+V может отвечать совсем не за вставку чего-то из буфера, а за вызов какого-нибудь окна настроек. Плюс, метод SendKeys всегда работает только с активным на данный момент окном, а может оказаться так, что на момент попытки вставки окно нового письма еще не отобразилось по какой-то причине... Иначе говоря мы слишком зависимы от тех факторов, на которые практически не можем повлиять и предусмотреть все практически нереально. И по факту, таким методом (помимо правильной вставки) мы можем получить либо ошибку, либо неверное действие и никакой вставки, либо вставится вообще не то, что требовалось. Тем не менее, код вставки через SendKeys я все же здесь тоже выложу хотя бы потому, что он прост, понятен и универсален(да и в большинстве случаев все же будет работать). К тому же у него все же есть одно очень большое преимущество - им можно вставить что угодно: хоть таблицу, хоть диаграмму, хоть фигуру. В общем все, что выделили на листе:

'---------------------------------------------------------------------------------------
' 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

Перед запуском кода необходимо сначала выделить на листе нужную диаграмму.


Однако я сторонник методов более надежных, пусть и более сложных. И если есть возможность сделать код, который будет работать более стабильно, то буду использовать именно его. Путь приведенный ниже метод не универсален и работает только с диаграммами - он более надежен, чем код выше. По сути метод основан на встроенной возможности сохранения диаграмм в файл на диске(метод Export) и на возможности вставить в письмо картинку с диска(Отправить письмо через Outlook с картинкой в теле письма). А больше ничего особо и не требуется - просто совместить эти две возможности:

'---------------------------------------------------------------------------------------
' 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

Loading

Добавить комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.