Страницы: 1
RSS
Вставка таблицы в письмо Outlook без форматирования
 
Добрый вечер, форумчане.
Взяла код Дмитрия (The_Prist) для формирования письма Outlook с таблицей из Excel и в этом месте случился затык - не происходит ничего.
Вроде бы и макросе прописала нужный диапазон, и в функции, а таблица не вставляется. Нужна вставка в письмо диапазона A4:B11

*PS и подпись меня подводит, подпись, как ты могла?
 
У меня нет исходного макроса, но могу сказать, что вы явно неправильно внесли в него диапазон. Вы указали диапазон в переменную sF - а она чуть выше объявлена как переменная со строковым значением, а не переменная с диапазоном, и позже в коде она используется в качестве названия файла.
Судя по тому, как устроен макрос, в нём не нужно указывать диапазон прямо в коде - вы выделяете нужную таблицу и запускаете макрос.

 

Не помогло. Если вставить таблицу в файл Дмитрия - работает, а если скопировать его код к себе - нет.

Текст макроса привожу ниже:

Код
Option Explicit
 
Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment 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
    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 = Range("AF4")    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Странно, что не отображается " & Range("B9") & "\Microsoft\Signatures\"
Dim sTblBody As String
sTblBody = ConvertRngToHTM(Selection)
     'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody  'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        '.Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        .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


Изменено: Maayun - 15.10.2019 22:27:12
 
В вышеприведенны код вместо
Код
.Body = sBody 'Текст сообщения

вставьте
Код
 .htmlbody = sBody & sTblBody
Изменено: Nordheim - 16.10.2019 08:44:38
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,шикарно, то, что надо.
Спасибо)
Страницы: 1
Наверх