MyTetra Share
Делитесь знаниями!
Вставить в письмо Outlook таблицу Excel с форматированием
16.03.2019
23:43
Текстовые метки: Outlook,Send,Mail,vba,Рассылка почты
Раздел: !Закладки - VBA - Outlook

Вставить в письмо Outlook таблицу Excel с форматированием

Про создание писем в Outlook через Visual Basic for Applications(VBA) Excel я уже писал пару статей, в том числе и о том, как вставить одну из стандартных подписей в письмо - Вставить в письмо подпись из Outlook через VBA(по умолчанию при создании писем из VBA подпись не вставляется, даже если это настроено параметрами почты). Но т.к. отправка происходит из Excel, то часто возникает и другой вопрос - как в письмо вставить не просто текст, а целую таблицу? Да еще со всем форматированием ячеек? Если речь о ручной вставке, то тут все просто: скопировали диапазон, перешли в письмо - вставили. Но если попробовать тоже самое кодом (через копировать-вставить) - ничего не получится(у Outlook просто нет метода Paste или что-то вроде того). Можно использовать метод SendKeys, но он весьма нестабилен и я стараюсь его вообще нигде не применять, только в случаях, когда по-другому ну вообще никак. Если же переносить таблицу кодом вроде такого:
.Body = Range("A1").Value & Range("A2").Value
то это будут только значения ячеек, но не их форматирование и уж никак не таблица.
Все дело в том, что таблица в теле письма это отдельный объект формата HTML. И при вставке через копировать-вставить руками Excel и Outlook делают за нас всю грязную работу по перекодировке скопированного в нужный формат HTML. А значит и нам надо каким-то образом конвертировать нужные ячейки в этот формат, да еще учесть всё форматирование. К примеру, есть такая таблица:

рис.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 'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код) With wbTmp.PublishObjects.Add( _ SourceType:=xlSourceRange, Filename:=sF, _ Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _ 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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

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

    'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)

    With wbTmp.PublishObjects.Add( _

         SourceType:=xlSourceRange, Filename:=sF, _

         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _

         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)


1

2

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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

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?
По сути основная задача выполнена, теперь вы сможете вкладывать в сообщение таблицу без потери форматирования.



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

  Пример вставки таблицы в письмо Outlook.xls (67,5 KiB, 329 скачиваний)


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

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


1

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


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

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


1

2

3

'Переносы строк и шрифт

sBody = Replace(sBody, Chr(10), "<br />")

sBody = Replace(sBody, vbNewLine, "<br />")


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

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

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


1

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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

'---------------------------------------------------------------------------------------

' 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 'уже не надо, т.к. форматирования нет .HTMLBody = RangeToTextTable(Selection) .Display 'отображаем сообщение End With


1

2

3

4

5

6

7

8

    'создаем сообщение

    With objMail

        .To = "адрес получателя"

        .Subject = "Тема: тест вставки таблицы"

        '.BodyFormat = 2  'уже не надо, т.к. форматирования нет

        .HTMLBody = 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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

'---------------------------------------------------------------------------------------

' 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 или любой другой мноноширный шрифт. Тогда можно получить примерно такой результат:

Если использовать не моноширный шрифт, то визуально таблица все равно будет неравной и смысла в модификации функции нет.

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования