Использую макрос для рассылки данных о качестве продажи сладостей сотрудниками шоколадной фабрики.
Код
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim c, u As String
Dim name, count As Integer
Dim PlaceY As Range
Dim rDataR As Range
Dim sBody As String
u = Worksheets("settings").Range("b3")
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
c = Worksheets("Settings").Range("b3").Value
sBody = Worksheets("Settings").Range("B4").Value
For i = 1 To c
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
name = ActiveWorkbook.Sheets("Settings").Range("c" & (i + 1)).Value
Worksheets("SMART").PivotTables("ÑâîäíàÿÒàáëèöà1").PivotFields("Ëîãèí îïåðàòîðà"). _
ClearAllFilters
Worksheets("SMART").PivotTables("ÑâîäíàÿÒàáëèöà1").PivotFields("Ëîãèí îïåðàòîðà"). _
CurrentPage = name
ThisWorkbook.Worksheets("smart").Select
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
sBody = Replace(sBody, Chr(10), "<br />")
sBody = Replace(sBody, vbNewLine, "<br />")
sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"
Set rDataR = Selection
sTblBody = ConvertRngToHTM(rDataR)
sBody = Replace(sBody, "{TABLE}", sTblBody)
With OutMail
.SentOnBehalfOfName = ActiveWorkbook.Sheets("Settings").Range("b1").Value
.Subject = ActiveWorkbook.Sheets("Settings").Range("b2").Value
.To = name & "@poctalion.mail"
.HTMLBody = sBody
.Display
' .Send
End With
Set OutApp = Nothing
Set OutMail = Nothing
'Application.Wait Time:=Now + TimeSerial(0, 0, 2)
Next i
With Application 'Turning graphical options back
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Worksheets("settings").Activate
End Sub
Код
Function будет в следующем сообщении - сейчас слишком много символов.
При работе данного кода первое письмо выглядит совершенно верно:
"1, png"
Однако все последующие принимают неудобоваримый вид:
"2, png"
Подскажите пожалуйста, что предпринять для корректной генерации писем?
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
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
Set rng = Nothing
End Function
Прошу прощения что заново поднимаю данную тему. Коллеги, прошу помочь. Подскажите пожалуйста, как с имеющимся кодом можно вставить несколько таблиц с разных листов в текст одного письма?
Kolesnikov написал: Всё отлично работает, большое спасибо!
Вы же писали, что всё работает. Вот и вызывайте функцию Сергея, просто передавая разные диапазоны Range с других листов [для примера, Workbooks("bookname.xlsx").Worksheets("worksheetname").Range("A2:G234") ] и соединяйте HTML описание таблиц в одну строку.
Андрей VG написал: Вот и вызывайте функцию Сергея, просто передавая разные диапазоны Rangе
Благодарю Вас, почему-то сам не додумался
Один небольшой вопрос по HTML, скорее всего.
В исходной таблице (3. png), данные отображены в процентах. К сожалению в письме это превращается в (4. png), подскажите пожалуйста, как сохранить расцветку и проценты?
Уважаемый Kolesnikov! Я бы посоветовал вернуться к использованию объекта PublishObjects, который учитывает все особенности форматирования ячеек. Редакция функции, которая допускает произвольное количество диапазонов в качестве параметров, каждый из которых к тому же может иметь несколько областей:
Код
Function ConvertRngToHTM(ParamArray rngs())
Dim fso As Object, ts As Object
Dim sF As String, rg As Range, rg2 As Range, v
sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects
.Delete
For Each v In rngs
If IsObject(v) Then
Set rg2 = v
Else
Set rg2 = Range(v)
End If
For Each rg In rg2.Areas
.Add xlSourceRange, sF, rg.Parent.Name, rg.Address, xlHtmlStatic
Next rg
Next v
.Publish
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
ConvertRngToHTM = ts.ReadAll
ts.Close
Kill sF
Set ts = Nothing
Set fso = Nothing
End Function
Уважаемый Sokol92, я вместе с табличкой хочу вставлять например диаграмму, как быть в этом случае. Можете помочь. Уже весь инет перевернул. Заранее спасибо.
Добавил в #11 возможность задания в качестве одного из параметров графического объекта.
Код
Function ConvertRngToHTM(ParamArray rngs())
Dim fso As Object, ts As Object
Dim sF As String, rg As Range, rg2 As Range, v
sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".mht"
With ActiveWorkbook.PublishObjects
.Delete
For Each v In rngs
Set rg2 = Nothing
If IsObject(v) Then
Select Case TypeName(v)
Case "Range"
Set rg2 = v
Case "ChartObject"
Set rg2 = Range(v.TopLeftCell, v.BottomRightCell)
End Select
Else
Set rg2 = Range(v)
End If
If Not rg2 Is Nothing Then
For Each rg In rg2.Areas
.Add xlSourceRange, sF, rg.Parent.Name, rg.Address, xlHtmlStatic
Next rg
End If
Next v
.Publish
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
ConvertRngToHTM = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End Function
Например:
Код
ConvertRngToHTM ActiveSheet.ChartObjects(1)
Пробуйте!
Изменено: sokol92 - 08.06.2018 19:42:36(Изменил расширение временного файла на .mht)
Добрый день, Владимир. Что то у меня ничего не получилось. Меняю на это преобразование, сразу все столбцы слетают, не говоря уже про диаграмму.. Может я не правильно делаю. Куда мне вставить запись:
Здравствуйте, mibs! Функция ConvertRngToHTM публикует диапазоны и графические объекты, заданные параметрами, во временный файл %Temp%\ДД-ММ-ГГ ЧЧ:MM:CC.mht и возвращает его (файла) содержимое. Написана по заказу автора темы. Содержимое файла можно просмотреть с помощью Internet Explorer.
Подскажите почему перестала работать функция, не появляется ошибок. В результат выполнения появляется письмо без втравленной таблицы и открытый фаил excel со скопированной таблицей.
Код
Function ConvertRngToHTM(rng As Range)
Dim 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
Не выполняется эта часть кода.
Код
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
Set rng = Nothing
Пример текущий приложил. В нем сейчас вроде все корректно, но вставленная таблица почему встает по центру письма с большим отступом справа.
Но как прикрутить его не понимаю. P.S. Уважаемые модераторы, если нужно могу создать новую тему с описанием общей задачи "Автоотправка отчета на почту как картинка"
написал: В результат выполнения появляется письмо без втравленной таблицы и открытый фаил excel со скопированной таблицей.
Добрый день! Присоединяюсь к вопросу. У меня также. Функция идин в один. Все работало вчера. После перезагрузки компа письмо без таблицы и вообще без текста, который HTMLbody. А таблица остается во временном файле эксель. Он открывается в отдельном окне. Помогите, пож-та!