Последнее время стал часто встречать вопрос о том, как в письмо, созданное кодом VBA в Excel, добавить стандартную подпись Outlook.
Как делать отправку писем я рассказывал в этой статье: Как отправить письмо из Excel?
Немного теории для тех, кто не знает
Чтобы создать подпись в Excel 2007 и выше необходимо перейти в меню:
для 2007 : Сервис -Параметры -Сообщение -Подписидля 2010 и выше : Файл(File) -Параметры(Options) -Почта(Mail) -Подписи(Signatures)
В появившемся окне на вкладке Электронная подпись
В этой же вкладке можно настроить использование подписей по умолчанию для выбранной учетной записи(для каждой учетной записи можно назначить свою подпись по умолчанию) - в правой части окна.
Чтобы после создания письма вставить любую из созданных ранее подписей необходимо из окна созданного сообщения перейти на вкладку Вставка
Как я уже упоминал вначале статьи - из VBA так же можно создавать письма в Outlook. Подробнее об этом можно прочитать в этой статье: Как отправить письмо из Excel?. И вот там как раз есть небольшой недостаток - при создании письма подпись не добавляется автоматом, даже если она создана и настроена для вставки в новые сообщения. Это и побудило меня написать данную статью. Дело в том, что все созданные подписи хранятся на ПК в определенном месте на диске(
Sub SeeSigns() Dim sSignPath As String Dim sF sSignPath = Environ("appdata") & "\Microsoft\Signatures\" '" sF = Dir(sSignPath & "*.txt") Do While sF <> "" MsgBox sF, vbInformation, "www.excel-vba.ru" sF = Dir Loop End Sub |
Этот код просматривает только текстовые подписи - т.е. без оформления в виде картинок и гиперссылок. Однако в самой папке помимо текстовых файлов есть файлы с форматированием в формате .htm. Они добавляются в письма, которые пишутся с применением форматирования, т.е. письма формата .HTML.
Если в письмо надо вставить исключительно подпись по умолчанию(которая на данный момент установлена), то можно схитрить: в момент создания нового письма кодом сначала отобразить его, считать весь текст. Что произойдет: когда письмо отображается, встроенный алгоритм Outlook добавляет к нему подпись по умолчанию, даже если текста нет. А мы в итоге просто считываем эту подпись:
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 End If 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) On Error GoTo 0 'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = "" 'адрес для копии .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения If Dir(sAttachment, 16) <> "" Then .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName End If 'обязательно отображаем письмо ДО отправки и добавления своего текста 'без этого может не подгрузиться подпись .Display 'добавляем к пустому письму с уже прогруженной подписью свой текст(sBody) .HTMLBody = sBody & .HTMLBody .Send '.Display ', если необходимо просмотреть сообщение, а не отправлять без просмотра End With Set objOutlookApp = Nothing Set objMail = Nothing Application.ScreenUpdating = True End Sub |
Такой фокус не пройдет если ни одна подпись не установлена в качестве подписи по умолчанию.
Чтобы сильно не заморачивать всеми премудростями и хитросплетениями кодинга я просто приложу файл, который умеет создавать письма с подписями, при этом можно выбрать нужную подпись и тип: простой текст или форматированный.
Tips_Macro_CreateMailWithSign.xls (66,5 КиБ, 3 750 скачиваний)
После скачивания файла прежде чем нажать кнопку
- в
В11 - адрес получателя(кому отправить письмо) - в
В12 - тема письма - в
В13 - текст письма
Если планируется отправить письмо с форматированием текста(жирный шрифт, различный цвет шрифта и т.п.) - то надо будет к письму применить теги HTML(ячейка
После нажатия Ок появится запрос:
Если нажать Нет
Рекомендую сначала пользоваться предпросмотром, чтобы понять как правильно создавать и форматировать письма.
Для тех, кто уже имеет опыт программирования в VBA, полагаю, не составит труда адаптировать код под какие-то свои коды или коды на этом сайте.
Если совсем не охота вдумываться в макросы и нужно готовое решение по рассылке с вложениями и подписями - есть готовое решение: Отправка листа/книги по почте
Так же см.:
Как отправить письмо из Excel?
Вставить в письмо Outlook таблицу Excel с форматированием
Сохранить вложения из Outlook в указанную папку
Как отправить письмо от другой учетной записи Outlook
Добрый день! Спасибо большое за вашу работу, очень помогает! Подскажите пожалуйста, как правильно вставить код подписи в Ваш готовый файл "Массовая рассылка писем по адресам", чтобы рассылка была с подписью?
Временное письмо не нужно. Достаточно отобразить письмо перед тем, как создавать его текст (body).
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Display
.body = sBody & .body 'текст сообщения до подписи
'.HTMLBody = sBody & .HTMLBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
.Send 'если необходимо сразу отправить
End With
Сергей, все дело в том, что это не всегда срабатывает как положено. Поэтому и делается копия для более корректной вставки именно подписи.
А если у меня в подписи картинка? как правильно сделать?
у меня так этот кусок выглядит:
...
.body = sBody 'текст сообщения
.HTMLBody = sBody
.....
.HTMLBody = sBody & .HTMLBody
Здравствуйте, как отправить активную лист, и почему не работает удаление всех формул?
За ранее благодарю!
Option Explicit
Sub КаТЗ()
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Dim objTmpMail As Object 'временное письмо для создания подписи
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 = "" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
sSubject = "Часовые" 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "" 'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
sAttachment = "" 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение
With objMail
.ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value ' удалить строку, если формулы нужны
.ReadReceiptRequested = True 'прочтение
.OriginatorDeliveryReportRequested = True 'доставка
.Importance = 2 'Варианты (0-normal, 1-low, 2-high)
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Body = sBody 'текст сообщения
.HTMLBody = sBody & .HTMLBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
.Attachments.Add ActiveWorkbook.Sheets("Отправка КАТЗ").Copy 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
'добавляем подпись к письму
'создаем новое письмо
Set objTmpMail = objOutlookApp.CreateItem(0)
'отображаем его - у него появится подпись
objTmpMail.Display
'теперь к нашему текущему(рабочему) письму просто добавляем текст из временного
objMail.Body = objMail.Body & objTmpMail.Body
objTmpMail.Delete 'удаляем временное письмо
.Display 'Display/Send, если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub