Макрос отправки Листа по почте

[Сергей Ш.]

Добрый день.
Есть макрос, который сохраняет лист и отправляет его по почте на указанный адресат, работает хорошо, только вот не вставляет подпись.
Что необходимо добавить в макрос что бы он при этом вставлял подпись и в заголовке писал "Добрый день." Помогите пожалуйста с макросом.

Sub Сохранить_Лист_в_Файл()

On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "Сверка\"
    ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER

    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = Application.GetSaveAsFilename("Сверка.xls", "Отчёты Excel (*.xls),", , _
        "Введите имя файла для сохраняемого отчёта", "Сохранить")
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
    If VarType(Filename) = vbBoolean Then Exit Sub

    ' копируем активный лист (при этом создаётся новая книга)
    Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем
Dim ra As Range, delra As Range
    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.UsedRange.Rows
    ' если строка полностью пустая
    If Not IsNull(ra.Text) Then
    ' добавляем строку в диапазон для удаления
    If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next
    ' если подходящие строки найдены - удаляем их
    If Not delra Is Nothing Then delra.EntireRow.Delete
    ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
With ActiveWorkbook
        .SendMail Recipients:="адресат@mail.ru", Subject:="Сверка"
        .Close SaveChanges:=False

End With
End If
End Sub

[EducatedFool]

Можете приспособить другой мой макрос для отправки письма через Outlook:
http://excelvba.ru/code/OutlookSendMail
Там можно задать тему и текст письма, прикрепить произвольные файлы, и т.д.

Или, то же самое, через TheBAT:
http://excelvba.ru/code/TheBAT

[Сергей Ш.]

Дело в том, что этим макросом мне удобнее пользоваться, т.к. отправляемый файл необходимо сразу переименовывать и сохранять (Лист) в заданную тобой папку. Вот думаю, как можно усовершенствовать макрос, что бы при отправке письма автоматом вставлялась подпись, которая по умолчанию стоит в Outlook, или хотя бы текст, который можно прописать в макросе.

[EducatedFool]

Если бы можно было усовершенствовать макрос, - я бы такое решение и предложил

Можете посмотреть параметры метода SendMail - там никаких наворотов не предусмотрено
Можно попробовать поколдовать с аутлуком (настроить формат письма по-умолчанию) - но не уверен, что такая возможность есть.

[AndVGri]

В принципе, можно захватиться за Worksheet.MailEnvelope (правда отправка по-видимому только через Outlook)

Public Sub TestMail()
    Dim pMail As MailItem
    Dim pEnv As MsoEnvelope
    Set pEnv = ActiveSheet.MailEnvelope
    Dim pos As Long, sHTML As String
    pEnv.Introduction = "Добрый день"
    Set pMail = pEnv.Item
    pMail.Subject = "Пояснительная таблица"
    pMail.To = "name@mail.com"
    sHTML = pMail.HTMLBody
    pos = InStrRev(sHTML, "</body>", Compare:=vbTextCompare)
    sHTML = Mid$(sHTML, 1, pos - 11)
    'текст подписи
    sHTML = sHTML & "<hr><p>С наилучшими пожеланиями. Отдел 007</p>"
    pMail.HTMLBody = sHTML & "</body></html>"
    pMail.Send
End Sub

К сожалению, есть проблема, модификация HTMLBody игнорируется, с другой стороны, можно воспользоваться Outlook для создания письма и отправить изменённый html.
P. S. А что вам мешает добавить строку в начале и вписать там "Добрый день", в последней строке добавить подпись, отправить и закрыть книгу без сохранения?