Про создание писем в Outlook через Visual Basic for Applications(VBA) Excel я уже писал пару статей, в том числе и о том, как вставить одну из стандартных подписей в письмо - Вставить в письмо подпись из Outlook через VBA(по умолчанию при создании писем из VBA подпись не вставляется, даже если это настроено параметрами почты). Но т.к. отправка происходит из Excel, то часто возникает и другой вопрос - как в письмо вставить не просто текст, а целую таблицу? Да еще со всем форматированием ячеек? Если речь о ручной вставке, то тут все просто: скопировали диапазон, перешли в письмо - вставили. Но если попробовать тоже самое кодом (через копировать-вставить) - ничего не получится(у Outlook просто нет метода Paste или что-то вроде того). Поэтому рассмотрим другие варианты выхода из ситуации и как можно вообще вставить таблицу в тело письма кодом:

 

Вставка методом SendKyes
Можно использовать метод SendKeys, но он весьма нестабилен и я стараюсь его вообще нигде не применять, только в случаях, когда по-другому ну вообще никак:

Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
 
    Application.ScreenUpdating = False
    'копируем выделенную таблицу
    Selection.Copy
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    On Error GoTo 0
    'создаем сообщение
    With objMail
        .To = "адрес получателя"
        .Subject = "Тема: тест вставки таблицы"
        .BodyFormat = 2  'olFormatHTML - формат HTML
        .Display 'отображаем сообщение
        'передаем управление ОС, чтобы завершились все лишние процессы
        DoEvents
        'посылаем команду нажатия клавиш Ctrl+V для вставки таблицы из буфера обмена
        Application.SendKeys "^v"
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Чем мне не нравится этот метод? Как уже писал - он не очень стабилен и может получиться так, что вставите скопированное не туда или вставка вообще не произойдет.
Если же переносить таблицу кодом вроде такого:
.Body = Range("A1").Value & Range("A2").Value
то это будут только значения ячеек, но не их форматирование и уж никак не таблица.

 

Вставка таблицы с полным форматированием через конвертирование в HTML
Все дело в том, что таблица в теле письма это отдельный объект формата HTML. И при вставке через копировать-вставить руками Excel и Outlook делают за нас всю грязную работу по перекодировке скопированного в нужный формат HTML. А значит и нам надо каким-то образом конвертировать нужные ячейки в этот формат, да еще учесть всё форматирование. К примеру, есть такая таблица:

Пример таблица для вставки в письмо Outlook
рис.1

Теперь эту таблицу надо вставить в письмо вместе с остальным текстом, чтобы было что-то вроде:
Письмо с форматированной таблицей
рис.2

Чтобы конвертировать нужные ячейки в самостоятельную таблицу в формате HTML я использую такую функцию:

Function ConvertRngToHTM(rng As Range)
    Dim fso As Object, ts As Object
    Dim sF As String, resHTM As String
    Dim wbTmp As Workbook
 
    sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'переносим указанный диапазон в новую книгу
    rng.Copy
    Set wbTmp = Workbooks.Add(1)
    With wbTmp.Sheets(1)
        'вставляем только ширину столбцов, значения и форматы
        .Cells(1).PasteSpecial xlPasteColumnWidths
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        'удаляем все объекты(фигуры, рисунки и пр.)
        '------------------------------------------
        'если рисунки и объекты нужны - удалить этот блок
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        '------------------------------------------
    End With
    'выставляем русскую кодировку (если кириллицы в тексте нет - можно убрать)
    wbTmp.WebOptions.Encoding = msoEncodingCyrillic
    'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
    With wbTmp.PublishObjects.Add( _
         SourceType:=xlSourceRange, Filename:=sF, _
         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address(1, 1, Application.ReferenceStyle), _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'открываем созданный файл как текстовый и считываем содержимое
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
    resHTM = ts.ReadAll
    ts.Close
    'выравниваем таблицу по левому краю(если надо оставить по центру - удалить эту строку)
    ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
    'закрываем временную книгу и удаляем
    wbTmp.Close False
    Kill sF
    'очищаем объектные переменные
    Set ts = Nothing: Set fso = Nothing
    Set wbTmp = Nothing
End Function

Все, что остается - это в нужный момент вызвать эту функцию и вставить в нужное место письма.
Например, для конвертации в текст HTML выделенного на листе диапазона необходимо выполнить код:

Dim sTblBody As String
sTblBody = ConvertRngToHTM(Selection)

Чтобы создать письмо в Outlook и вставить туда эту таблицу можно использовать такой код:

Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    On Error GoTo 0
    'создаем сообщение
    With objMail
        .To = "адрес получателя"
        .Subject = "Тема: тест вставки таблицы"
        .BodyFormat = 2  'olFormatHTML - формат HTML
        .HTMLBody = ConvertRngToHTM(Selection)
        .Display 'отображаем сообщение
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Более подробно про создание и отправку писем из Excel я писал в этой статье: Как отправить письмо из Excel?
По сути основная задача выполнена, теперь вы сможете вкладывать в сообщение таблицу без потери форматирования.
Если задача поставлена так, что необходимо вставить таблицу не на основании выделенного диапазона(Selection), а на основании конкретного диапазона ячеек на листе(скажем диапазона A20:F27 на листе с именем Лист1), то это должно выглядеть так:

Dim sTblBody As String
sTblBody = ConvertRngToHTM(Worksheets("Лист1").Range("A20:F27"))

Скачать файл:

  Пример вставки таблицы в письмо Outlook.xls (66,0 КиБ, 3 902 скачиваний)


В файле-примере, приложенном к статье, более расширенный вариант кода, который оформлен более удобно, там можно задать в ячейках адрес получателя, тему письма и текст письма. Плюс помимо описанного выше добавляет форматирование к письму, проставляет корректные переносы и непосредственно вставляет таблицу в любое место письма.
За форматирование(назначает шрифт Arial, размер 14) отвечает строка:

sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"

Полагаю, несложно догадаться где изменить размер шрифта и его имя. Так же можно и иное форматирование применять, если Вам знакомы основы работы с HTML.
Корректные для HTML переносы строк текста

'Переносы строк и шрифт
sBody = Replace(sBody, Chr(10), "<br />")
sBody = Replace(sBody, vbNewLine, "<br />")

Про вставку таблицы следует расписать чуть подробнее. В примере в ячейку B13 записан следующий текст:
Уважаемый клиент!
Только для Вас мы подготовили специальное предложение по товарам, которыми Вы интересовались в нашем Интернет-магазине:
{TABLE}
Будем рады видеть Вас среди наших постоянных клиентов!
(а для постоянных клиентов у нас действуют еще более выгодные условия)
С уважением, Дмитрий
менеджер по работе с постоянными клиентами

красным специально выделен тег {TABLE}. Именно на место этого тега будет вставлена таблица, созданная из указанного диапазона и результат будет как на рис.2(см.выше). Эту метку можно вставлять в любое место и именно туда будет помещена таблица.
В коде диапазон вставляемой таблицы указывается в строке:

Set rDataR = .Range("A15:D18") 'Selection - если надо отправить только выделенные диапазона

Его можно изменить на любой необходимый.
Что важно помнить: если помимо вставки таблицы Вы планируете форматировать письмо другими тегами HTML, то лучше сначала сделать все форматирование и только в самом конце, самым последним шагом, добавлять таблицу в письмо. Иначе разметка таблицы может "поплыть".

Надеюсь теперь Вам не составит труда сделать свои сообщения более красивыми и аккуратными.

Понимаю, что многие захотят сделать из этого массовую рассылку. Для этого придется совместить код из этой статьи с кодом из статьи Как отправить письмо из Excel?. Там есть пример отправки писем через Outlook списку получателей.

 

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

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
' Purpose: функция объединяет значения указанного диапазона ячеек в строку
'          разрывы между столбцами заменяются табуляцией
'          разрывы между строками заменяются переносами на строки
'---------------------------------------------------------------------------------------
Function RangeToTextTable(rng As Range)
    Dim lr As Long, lc As Long, arr
    Dim res As String
 
    arr = rng.Value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rng.Value
    End If
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            If lc = 1 Then
                res = res & arr(lr, lc)
            Else
                res = res & vbTab & arr(lr, lc)
            End If
        Next
        res = res & vbNewLine
    Next
    RangeToTextTable = res
End Function

Вставляем значения ячеек при помощи этой функции в письмо:

    'создаем сообщение
    With objMail
        .To = "адрес получателя"
        .Subject = "Тема: тест вставки таблицы"
        '.BodyFormat = 2  'уже не надо, т.к. форматирования нет
        .Body = RangeToTextTable(Selection)
        .Display 'отображаем сообщение
    End With

Здесь следует помнить, что "таблица" после такой вставки будет выглядеть не очень красиво. И речь не о цвете заголовков - при различной длине текста внутри ячеек текст в письме будет сдвигаться:
Письмо без форматирования
чтобы этого как-то избежать, можно чуть модифицировать функцию:

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: функция объединяет значения указанного диапазона ячеек в строку
'          разрывы между столбцами заменяются табуляцией
'          разрывы между строками заменяются переносами на строки
'---------------------------------------------------------------------------------------
Function RangeToTextTable(rng As Range)
    Dim lr As Long, lc As Long, arr
    Dim res As String, rh()
    Dim lSpaces As Long, s As String
 
    arr = rng.Value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rng.Value
    End If
    ReDim rh(1 To UBound(arr, 2))
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            If Len(arr(lr, lc)) > rh(lc) Then
                rh(lc) = Len(arr(lr, lc))
            End If
        Next
    Next
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            s = arr(lr, lc)
            lSpaces = rh(lc) - Len(s)
            If lSpaces > 0 Then
                s = s & Space(lSpaces)
            End If
            If lc = 1 Then
                res = res & s
            Else
                res = res & vbTab & s
            End If
        Next
        res = res & vbNewLine
    Next
    RangeToTextTable = res
End Function

и назначить шрифт для писем по умолчанию Courier New или любой другой мноноширный шрифт. Тогда можно получить примерно такой результат:
Таблица в письме без форматирования моноширным шрифтом
Если использовать не моноширный шрифт, то визуально таблица все равно будет неравной и смысла в модификации функции нет.

Так же см.:
Как отправить письмо из Excel?
Вставить в письмо подпись из Outlook через VBA
Сохранить вложения из Outlook в указанную папку
Как отправить письмо от другой учетной записи Outlook

Loading

13 комментариев

  1. Огромное спасибо! Все очень доступно расписано и прекрасно работает. У меня возник только один вопрос. Как в таблице оставить гиперссылки? При преобразовании они удаляются(

    1. Все работает, только текст, который вне таблицы читается хорошо, а вот сама таблица вставляется в виде иероглифов. С чем это может быть связано?

  2. Добрый день! Функция перестала работать. Вставляется только текст. Таблица выгружается на отдельный лист эксель, который открывается в другом окне.

    1. Мария, только что скачал файл из статьи, запустил код - создалось письмо с таблицей, все корректно.
      Возможно, Вы вносили какие-то правки в код или используете функцию как-то иначе.

  3. Здраствуйте, для работы интересна функция которая в письмо вкладывает значения всех ячеек указанного диапазона простым текстом. При попытке запустить макрос вся таблица в письме получается в строчку (отсутствуют переносы на другую строку, код без изменения), что может быть не так?

  4. Макросы всё работают замечательно, но вставляемая таблица при вставке в тело письма теряет изменённые форматы ячеек, сделанные условным форматированием. Что можно сделать?

  5. Добрый вечер! Огромное спасибо за статью!
    При установке модуля из раздела "конвертировать нужные ячейки в самостоятельную таблицу в формате HTML" и модуля из Вашей статьи "ОТПРАВКА СООБЩЕНИЯ БЕЗ ИСПОЛЬЗОВАНИЯ OUTLOOK - ИСПОЛЬЗУЕМ CDO" все работает, но ... кнопки (ActiveX, 4 штуки на листе), стали утапливаться и не отжиматься пока не прокрутишь колесиком мыши (макросы, вызываемые кнопками, стали работать медленнее). Иногда подвисает Excel (не активируются ячейки даже при выделении мышкой) после выполнения макросов, вызываемых кнопками. Самих данных очень мало. Книга используется для авторизации пользователя (тоже Ваша статья))) и ведения Журнала записей. Кнопки используются для добавления записи, сохранения, изменения и удаления. При сохранении новой записи, изменении, удалении ведется лог: кто это сделал, когда и сохраняется сама запись на скрытом листе. Письмо отправляется только при добавлении новых записей для оповещения заинтересованных Пользователей. После удаления модуля из статьи "ОТПРАВКА СООБЩЕНИЯ БЕЗ ИСПОЛЬЗОВАНИЯ OUTLOOK - ИСПОЛЬЗУЕМ CDO", все работает снова нормально.

    1. Сергей, не совсем понятно, в чем именно вопрос. Если именно по работе кнопок - то здесь надо разбираться. Например, использование ActiveX уже давно не рекомендуется, т.к. может сбоить(вот, например: Элементы ActiveX перестали работать или ведут себя непредсказуемо). Лучше заменять на элементы форм или фигуры. И посмотреть на их поведение.
      Так же возможно и сами компоненты на ПК где-то глючат или с чем-то конфликтуют. Или те же макросы конфликтуют между собой. Здесь дистанционно помочь практически нереально.

      1. Добрый день, Дмитрий!
        Вопроса как такового и не было. Довел до Вас как разработчика (реально крутого) суть возникающих проблем при установке модуля.
        Спасибо за совет

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

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