Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос копирования таблицы и вставки в письмо как картинки
 
Всем доброго дня.

Есть табличка в Экселе, у меня есть макрос, который переносит эту табличку в письмо.
Подскажите, как его отредактировать, чтобы переносилась картинка? То есть копипаст, но в письмо должно вставляться картинкой.

Заранее спасибо :)
Код
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
 
Цитата
Breathe of fate написал:
То есть копипаст, но в письмо должно вставляться картинкой
вот на том же сайте, откуда взяли код можно подсмотреть и как создать картинку из диапазона и как потом вставить в письмо эту картинку:
Как сохранить картинки из листа Excel в картинки JPG
Отправить письма через Outlook с картинкой в теле письма
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков,

в общем, у меня не получилось. И всё немного сложнее :)

Задача: есть файлик эксель, в котором есть макрос, который делает копию файла (присваивая ему имя) в эксель и в пдф. То есть файл 1.xlsm -> 2.xlsm, 2.pdf.
Теперь я хочу, чтобы после создания этих двух файлов открывалось письмо с уже заполненными адресатами (это я смогу сделать), с выделенным диапазоном в 1.xlsm и вставлённым в тело письма картинкой, а так же уже прикреплённым 2.pdf (имя постоянно меняется, поэтому хочется прикрутить диалоговое окно выбора) :) То есть мне остаётся только проверить и отправить.

Это реально сделать средствами VBA?
Изменено: Breathe of fate - 31 окт 2020 11:27:34
 
Доброе время суток.
Цитата
Breathe of fate написал:
И всё немного сложнее
В чём сложность?
1. В файле 1.xlsm запускается процесс
2. файл 1.xlsm сохраняется в 2.xlsm (имя сохранённого файла известно)
3. файл 1.xlsm сохраняется в 2.pdf (имя сохранённого файла известно, иначе - как вы его сохраняли)
4. из файла 1.xlsm диапазон сохраняется как растр в файл (имя сохранённого файла известно)
5. создаётся тело письма с картинкой из 4
6. добавляется вложение на файл из 3
7. письмо дополняется получателями
8. отправляется.
Что в этом процессе мешает использовать предложенный Дмитрием код? Только отсутствие навыков программирования :)
 
Андрей VG,
умел бы я кодить - я бы не спрашивал...  
 
Цитата
Breathe of fate написал:
умел бы я кодить - я бы не спрашивал...  
На основании чего вы решили, что умеющие кодить - не спрашивают? Да сплошь и рядом :)  Только спрашиваете вы странно
Цитата
Breathe of fate написал:
как его отредактировать, чтобы переносилась картинка?
Ответ же на так поставленный вопрос звучит, как написал Дмитрий - использовать код - далее по ссылкам. И вместо того чтобы попросить кого-нибудь вставить код, раз вы не способны кодить, вы пускаетесь в какие-то сентенции по поводу какой-то сложности.
 
Добрый день.

Подскжите, пожалуйста, что здесь неправильно:
Код
Sub Send_Mail_With_Picture()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String, sPicture As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    'ïðîáóåì ïîäêëþ÷èòüñÿ ê Outlook, åñëè îí óæå îòêðûò
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook çàêðûò, î÷èùàåì îøèáêó
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'objOutlookApp.Session.Logon "user","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'ñîçäàåì íîâîå ñîîáùåíèå
    'åñëè íå ïîëó÷èëîñü ñîçäàòü ïðèëîæåíèå èëè ýêçåìïëÿð ñîîáùåíèÿ - âûõîäèì
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "AddressTo@mail.ru"    'Êîìó(ìîæíî çàìåíèòü çíà÷åíèåì èç ÿ÷åéêè - sTo = Range("A1").Value)
    sSubject = "Àâòîîòïðàâêà"    'Òåìà ïèñüìà(ìîæíî çàìåíèòü çíà÷åíèåì èç ÿ÷åéêè - sSubject = Range("A2").Value)
    sBody = "Ïðèâåò îò Excel-VBA"    'Òåêñò ïèñüìà(ìîæíî çàìåíèòü çíà÷åíèåì èç ÿ÷åéêè - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Êíèãà1.xls"    'Âëîæåíèå(ïîëíûé ïóòü ê ôàéëó. Ìîæíî çàìåíèòü çíà÷åíèåì èç ÿ÷åéêè - sAttachment = Range("A4").Value)
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "ïîø¸ë â æîïó", vbCritical, "Èãîðÿí ïèøåò:"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Range("B2:F3")
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'ñîçäàåì ñîîáùåíèå
    With objMail
        .To = sTo 'àäðåñ ïîëó÷àòåëÿ
        .CC = "" 'àäðåñ äëÿ êîïèè
        .BCC = "" 'àäðåñ äëÿ ñêðûòîé êîïèè
        .Subject = sSubject 'òåìà ñîîáùåíèÿ
        .Body = .Paste
        '÷òîáû êàðòèíêà áûëà âèäíà âíóòðè ñîîáùåíèÿ - íàäî å¸ ñíà÷àëà äîáàâèòü êàê âëîæåíèå
        'åñëè êàðòèíêà ïî óêàçàííîìó ïóòè ñóùåñòâóåò(dir ïðîâåðÿåò ýòî)
        If Dir(sPicture, 16) <> "" Then
            If Dir(sPicture, 16) <> "" Then
                .Attachments.Add sPicture
                'òåïåðü âñòàâëÿåì êîä êàðòèíêè
            End If
        End If
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
Изменено: Breathe of fate - 2 ноя 2020 07:24:47
 
Цитата
Breathe of fate написал:
что здесь неправильно
все правильно. Но код по сохранению картинки Вы перенесли не до конца. Там еще должно быть использование метода Export(плюс пара строк). Присмотритесь внимательно к коду в статье, на которую я давал ссылку.
Да и для переменной sPicture у Вас нет никакого значения...
Изменено: Дмитрий(The_Prist) Щербаков - 2 ноя 2020 08:57:38
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Breathe of fate написал:
Подскжите, пожалуйста, что здесь неправильно:
1. При копировании кода Вы забыли переключиться на рус регистр, поэтому много непонятных символов.
Изменено: Михаил Лебедев - 2 ноя 2020 10:27:19
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
все правильно. Но код по сохранению картинки Вы перенесли не до конца. Там еще должно быть использование метода Export(плюс пара строк).
Код
    Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Выделенная область не является диапазоном!", vbCritical, "www.excel-vba.ru"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".gif", FilterName:="GIF"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Вы об этом коде? Я его так и перенёс...
Изменено: Breathe of fate - 2 ноя 2020 14:20:08
 
Цитата
Breathe of fate написал:
Я его так и перенёс.
ну вот я даже не знаю тогда как еще сказать, если Вы не видите разницы между кодом из статьи и Вашего последнего сообщения и кодом из сообщения 7. Вы точно не замечаете, что между строками
Код
With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
и
Код
End With
должно быть 5 строк, а у Вас в сообщении 7 одна?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
Вы точно не замечаете, что между строками

Код
Sub Send_Mail_With_Picture()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String, sPicture As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'objOutlookApp.Session.Logon "user","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
  
    sTo = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "пошёл в жопу", vbCritical, "Игорян пишет:"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Range("B2:F3")
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".gif", FilterName:="GIF"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = .Paste
        'чтобы картинка была видна внутри сообщения - надо её сначала добавить как вложение
        'если картинка по указанному пути существует(dir проверяет это)
        If Dir(sPicture, 16) <> "" Then
            If Dir(sPicture, 16) <> "" Then
                .Attachments.Add sPicture
                'теперь вставляем код картинки
            End If
        End If
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

А, я понял о каком куске Вы говорите. Добаивл. Только всё равно ошибка при выполнении.
Изменено: Breathe of fate - 3 ноя 2020 07:15:15
 
Цитата
Breathe of fate написал:
всё равно ошибка при выполнении
мы теперь должны догадаться что за ошибка?
Плюс до сих пор:
Цитата
Дмитрий(The_Prist) Щербаков написал:
для переменной sPicture у Вас нет никакого значения
А это значит, что в If Dir(sPicture, 16) <> "" Then Вы проверяете пустоту и ничего приложено, конечно же, не будет.
Далее не вижу НИ СТРОКА кода, которая бы хотя бы намекала на то, что Вы хотите вложить картинку в сообщение именно как часть сообщения, а не как вложение. А это важно. Откуда Вы вообще взяли это?
Цитата
Breathe of fate написал:
.Body = .Paste
Не помню такого у себя в статье. В общем по факту Вы опять скопировали/написали не то, что есть в статье, а то что придумали сами.


P.S. И вот это лучше заменить(для форума), ибо не совсем культурно это выкладывать на всеобщее обозрение:
Цитата
Breathe of fate написал:
MsgBox "пошёл в жопу", vbCritical, "Игорян пишет:"
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
мы теперь должны догадаться что за ошибка
Compile error. Expected end with

Цитата
Дмитрий(The_Prist) Щербаков написал:
Далее не вижу НИ СТРОКА кода, которая бы хотя бы намекала на то, что Вы хотите вложить картинку в сообщение именно как часть сообщения, а не как вложение. А это важно.
Поэтому я и прошу помощи :) Если бы я знал, что там надо писать - я бы это сделал.

Цитата
Дмитрий(The_Prist) Щербаков написал:
Не помню такого у себя в статье. В общем по факту Вы опять скопировали/написали не то, что есть в статье, а то что придумали сами.
Потому что просто копипаст у меня не сработал. Пытался разобраться, пробовал.  
 
Добрый день.

Решил проблему не картинкой, но таблицей.

Тему можно закрывать.
Страницы: 1
Читают тему (гостей: 1)
Наверх