Всем доброго дня.
Есть табличка в Экселе, у меня есть макрос, который переносит эту табличку в письмо.
Подскажите, как его отредактировать, чтобы переносилась картинка? То есть копипаст, но в письмо должно вставляться картинкой.
Заранее спасибо
Есть табличка в Экселе, у меня есть макрос, который переносит эту табличку в письмо.
Подскажите, как его отредактировать, чтобы переносилась картинка? То есть копипаст, но в письмо должно вставляться картинкой.
Заранее спасибо
Код |
---|
Sub Send_Mail() Dim oOutlApp As Object, objMail As Object Dim sTo As String, sSubject As String, sBody As String, sTblBody As String, sAttachment As String Dim rDataR As Range Dim IsOultOpen As Boolean Application.ScreenUpdating = False 'Пробуем подключиться к Outlook On Error Resume Next Set oOutlApp = GetObject(, "Outlook.Application") If Err = 0 Then IsOultOpen = True Else Err.Clear Set oOutlApp = CreateObject("Outlook.Application") End If oOutlApp.Session.Logon Set objMail = oOutlApp.CreateItem(0) 'создаем новое сообщение 'если не получилось создать приложение или экземпляр сообщения - выходим If Err.Number <> 0 Then Set oOutlApp = Nothing: Set objMail = Nothing: Exit Sub With ActiveWorkbook.Sheets("Status") sTo = .Range("P2").Value sSubject = .Range("P3").Value sBody = .Range("P4").Value 'Переносы строк и шрифт sBody = Replace(sBody, Chr(10), "<br />") sBody = Replace(sBody, vbNewLine, "<br />") sBody = "<span style=""font-size: 14.5px; font-family: Arial"">" & sBody & "</span>" 'Таблица 'важно добавлять таблицу после оформления переносов строк и шрифта 'в противном случае форматирование таблицы может "поплыть" Set rDataR = .Range("A1:N14") 'Selection - если надо отправить только выделенные диапазона sTblBody = ConvertRngToHTM(rDataR) 'подменяем метку {TABLE} в тексте письма реальной таблицей(сформированной выше) sBody = Replace(sBody, "{TABLE}", sTblBody) End With 'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = [P5] 'адрес для копии ' .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения .BodyFormat = 2 'olFormatHTML - формат HTML ' .Body = RangeToTextTable(Selection) 'вставляем таблицу без форматирования .HTMLBody = sBody If sAttachment <> "" Then .Attachments.Add sAttachment End If .display 'если необходимо просмотреть сообщение, а не отправлять без просмотра '.Send 'если необходимо отправить сообщение без просмотра End With If IsOultOpen = False Then oOutlApp.Quit Set oOutlApp = Nothing: Set objMail = Nothing DoEvents 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 '--------------------------------------------------------------------------------------- ' 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 |