Добрый день уважаемые пользователи форума.
Подскажите, пожалуйста:
При нажатии на кнопку "отправить письмо" в Outlook в письме автоматически заполняется имейл получателя тема письма, скриншот №1.
Если выделить табличку, то в Outlook в письме автоматически заполняется имейл получателя тема письма и в тело письма уходит табличка также табличка.
Подскажите, пожалуйста: можно ли как то в коде макроса дописать, что бы при нажатии на кнопу "отправить письмо" в тему письма подставлялся автоматически номер магазина из ячейки D16, а в тело письма автоматически подставлялась табличка как на скриншоте № 2.
Если это возможно то подскажите, что и где дописать в коде.
Заранее благодарю.
Код макроса в спойлере ниже:
Файлик прикрепляю также.
Подскажите, пожалуйста:
При нажатии на кнопку "отправить письмо" в 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 |
Файлик прикрепляю также.