- Open Notes - http://opennotes.ru -

Автоматическая отправка письма через Excel

Если после выполнения макроса необходимо отправить в качестве вложения получившийся документ Excel, можно использовать следующий код. Он создаёт письмо с нужным перечнем адресатов в полях «Кому» и «Копия», с указанной темой, текстом и прикреплённым Excel файлом. Остаётся толкьо дописать письмо в случае необходимости и нажать кнопку «Отправить».

Dim OutlookApp As Object, SM As Object
 Set OutlookApp = CreateObject("Outlook.Application")
 Set SM = OutlookApp.CreateItem(olMailItem)
 'SM.SentOnBehalfOfName = "mail@example.ru" 'Поле "От", если нужен другой отправитель
 SM.To = "mail@example.ru" 'Поле "Кому"
 SM.CC = "mail@example.ru" 'Поле "Копия"
 SM.Subject = "Тема письма"
 On Error Resume Next
 SM.Body = "Текст письма"
 SM.Attachments.Add ("C:\Test.xls") 'Адрес вложения
 SM.Display
 Set SM = Nothing
 Set OutlookApp = Nothing

Если же нужно отправить письмо в фоновом режиме, без отображения и необходимости самостоятельно нажимать кнопку «Отправить», то вместо SM.Display нужно вставить следующий код:

 SM.Send
 OutlookApp.Quit

Чтобы вместо простого текста в теле письма было отформатированное содержимое можно воспользоваться вместо SM.Body следующее:

 SM.HTMLBody =  "<html><body><div>" & Text & "</div></body></html>"

Чтобы создать письмо с подписью, которая ставится по умолчанию, можно прибегнуть к следующему коду:

Sub cbSendMail_Click(FileName)
 Application.DisplayAlerts = False
 FullFilePath = ThisWorkbook.Path & "\" & FileName & ".xlsx"
 Dim OutlookApp As Object, SM As Object
 Set OutlookApp = CreateObject("Outlook.Application")
 Set SM = OutlookApp.CreateItem(olMailItem)
 SM.To = "mail@example.ru"
 SM.CC = "mail@example.ru"
 SM.Subject = "Название темы" & FileName
 On Error Resume Next
 'в этом случае открывается письмо 
 'с подписью той которая по умолчанию в Outlooke
 SM.Body = Activedocument.Content
 SM.HTMLBody = Activedocument.Content.Text
 If Dir(FullFilePath) <> "" Then
 SM.Attachments.Add (FullFilePath) 'Адрес вложения
 Else
 MsgBox "Файл для вложения не найден: " & Chr(13) & FullFilePath
 End If
 SM.Display
 SM.HTMLBody = "Добрый день!" & SM.HTMLBody
 Set SM = Nothing
 Set OutlookApp = Nothing
End Sub

Ещё по теме

Источник: Клуб ПРОграммистов — Отправка почты макросом Excel

Order_macros