Добрый день уважаемые пользователи форума.

Подскажите, пожалуйста:

При нажатии на кнопку "отправить письмо" в Outlook в письме автоматически заполняется имейл получателя тема письма, скриншот №1.
Если выделить табличку, то в Outlook в письме автоматически заполняется имейл получателя тема письма и в тело письма уходит табличка также табличка.

Подскажите, пожалуйста: можно ли как то в коде макроса дописать, что бы при нажатии на кнопу "отправить письмо" в тему письма подставлялся автоматически номер магазина из ячейки D16, а в тело письма автоматически подставлялась табличка как на скриншоте № 2.  

Если это возможно то подскажите, что и где дописать в коде.

Заранее благодарю.

Код макроса в спойлере ниже:

Скрытый текст

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 = Range("D20").Value       .Subject = "Магазин № "       .BodyFormat = 2  'olFormatHTML - формат HTML       .HTMLBody = ConvertRngToHTM(Selection)       .Display 'отображаем сообщение   End With   Set objOutlookApp = Nothing: Set objMail = Nothing   Application.ScreenUpdating = True End Sub 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

Файлик прикрепляю также.