Рассылка писем через Outlook с использованием макросов Word.
Эта тема рассматривается на различных форумах сайтов. Есть и предлагаются отдельные решения.
В процессе решения этой задачи приходится рассматривать попутно несколько задач. Например, а сколько строк в отсылаемом тексте письма (что не главное), как сформировать текст письма, взяв его из файла Word, как создать письмо в формате HTML, как подсоединить к письму подпись и, желательно, стандартную.
Все подписи хранятся в папке Шаблоны как сигнатуры.
Одновременно при переводе письма в HTML код каким-то образом необходимо определить окончание каждой строки, чтобы преобразовать или удалить его код, заменив на код переноса строки в языке HTML. Кроме этого может возникнуть задача не просто создавать письмо, а создавать рассылку и не одну. В письмо в формате HTML обычно добавляют какой-то рисунок или логотип. У меня в примере это реализовано. Сразу же скажу о двух проблемах.
Первая. Рисунок никак не хотел размещаться по центру ячейки. Только слева или справа. Для этого пришлось разбивать строку на 3 ячейки.
Вторая. При автоматическом добавлении подписи, даже в формате HTML из шаблона подписей весь текст письма исчезал, кроме самой подписи. Из-за этого подпись пришлось просто вставить в текст самого кода HTML.
Третья. Коды окончания строки могут быть разными в разных приложениях. Это и код 10, и код 13. Мне более всего нравится задание кода в формате ^p. Я использую его довольно давно, когда попробовал копировать таблицы Word в Excel. Многие пользователи внутри ячеек таблиц Word умудряются нажимать на Enter, формируя этим дополнительный абзац, который при переводе таблицы в Excel превращается в пустую строку, что приводит к разрыву текста в ячейке. Из-за этого перед копированием текста Word желательно убрать макросом или поиском с заменой все лишние коды переноса.
Четвёртая. При повторной рассылке необходимо преобразованный под формат HTML код вернуть в первоначальный вид.
Я публикую все макросы из файла Normal.dot. Публикую даже с лишним, неиспользуемым на самом деле кодом.
Sub Delete_ПИ() ‘Добавить_BR работает аналогично
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.text = “^p”
.Replacement.text = ” ” ‘Здесь можно вставить любую комбинацию символов, например <br>
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
*********************
Sub Delete_BR()
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.text = “<br>”
.Replacement.text = ” ”
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
************************
Sub Убрать_Pi() ‘Это вариант, предлагаемый одним из авторов из Интернет. Я использую более простой макрос
‘Код можно усовершенствовать для последовательной обработки строк теста документа
Dim myText As String
‘1. Удаляем часть ненужных данных VBA-средствами.
‘1.1. Берём вообще весь текст из документа в переменную “myText”.
myText = ActiveDocument.Range.text
‘1.2. Удаляем из текста символ “Подача строки”.
‘В программе “Word” символ “Подача строки” не ставится,
‘если нажимать клавишу “Enter”, но если вставлять данные
‘из других документов и в этих документах есть такой символ,
‘то этот символ находится в Word-документе и пользователь ничего
‘не знает о его существовании.
myText = Replace(myText, Chr(10), “”)
‘1.3. Вставляем обработанный текст обратно в документ.
ActiveDocument.Range.text = myText
‘2. Остальное удаляем VBA-Word-средствами.
‘2.1. Удаляем знак абзаца, если перед знаком абзаца есть
‘любой символ, кроме знака абзаца и вставляем пробел.
With ActiveDocument.Range.Find
.text = “(^13)([!^13])”
.Replacement.text = ” \2″
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
‘2.2. Удаляем пробел после символа “Конец абзаца”.
With ActiveDocument.Range.Find
.text = “(^13)( )”
.Replacement.text = “\1”
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End Sub
‘Исходный (первоначальный вариант) с сайта www.excel-vba.ru, где используется и форма для выбора типа файла подписи
Файл Tips_Macro_CreateMailWithSign
‘ Module : mCreateMailWithSign
‘ Author : The_Prist(Дмитрий)
‘ WebMoney – R298726502453; Яндекс.Деньги – 41001332272872
‘ www.excel-vba.ru
‘ Purpose : http://www.excel-vba.ru/chto-umeet-excel/vstavit-v-pismo-podpis-iz-outlook-cherez-vba/
‘—————————————————————————————
Option Explicit
Public Const sAppName As String = “www.excel-vba.ru”
Public sSignPath As String
‘
Sub ShowSignsUF()
ufSigns.Show
End Sub
Function Send_MailWithSign(sSignTxt As String, IsHTMLBody As Boolean)
Dim objOutlApp As Object, oMail As Object, dicSigns As Object
Dim li As Long, sF
Dim wsSh As Worksheet
Dim lp As Long, s As String, sEx As String
Dim IsNotAppRun As Boolean, IsSend As Boolean
Dim sTo As String, sSubj As String, sBody As String
‘запрашиваем – надо ли письмо сразу отправлять или сначала посмотреть
IsSend = MsgBox(“Отправлять письмо без предпросмотра?” & vbNewLine & _
“При нажатии Нет(No) письмо будет создано и выведено на экран, но не будет отправлено.”, vbQuestion + vbYesNo, “www.excel-vba.ru”) = vbYes
‘получаем данные по теме, тексту и e-mail
With ThisWorkbook.Sheets(“Отправка”)
sTo = .Range(“B11”).Value
sSubj = .Range(“B12”).Value
sBody = .Range(“B13”).Value
End With
If sTo = “” Then
MsgBox “Не указан e-mail получателя”, vbCritical, “www.excel-vba.ru”
Exit Function
End If
If sSubj = “” Then
If MsgBox(“Тема письма не указана. Отправить без темы?”, vbInformation + vbYesNo, “www.excel-vba.ru”) = vbNo Then
Exit Function
End If
End If
If sBody = “” Then
If MsgBox(“Текст письма не указан. Отправить без текста?”, vbInformation + vbYesNo, “www.excel-vba.ru”) = vbNo Then
Exit Function
End If
End If
‘подключаемся к Outlook
On Error Resume Next
Set objOutlApp = GetObject(, “outlook.Application”)
If objOutlApp Is Nothing Then
Set objOutlApp = CreateObject(“outlook.Application”)
IsNotAppRun = True
End If
objOutlApp.Session.Logon
Set oMail = objOutlApp.CreateItem(0)
objOutlApp.Visible = True
‘создаем новое письмо
With oMail
.To = sTo ‘кому отправляем
.Subject = sSubj ‘тема письма
‘форматированное письмо
If IsHTMLBody Then
.htmlBody = sBody & String(4, vbCrLf) & sSignTxt
Else ‘простой текст
.Body = sBody & String(4, vbCrLf) & sSignTxt
End If
If IsSend Then ‘если надо сразу отправить письмо
.send
Else
.Display ‘если надо сначала посмотреть результат
End If
End With
‘Если приложение Outlook было открыто кодом – закрываем
If IsNotAppRun And IsSend Then
objOutlApp.Quit
End If
Set oMail = Nothing
Set objOutlApp = Nothing
End Function
Работающий код
************************
Option Explicit
Sub Create_Brief_Html()
‘Attribute VB_Name = “Пример HTML файла”
Dim oOutlook As Outlook.Application
Set oOutlook = New Outlook.Application
Dim oNameSpace As Outlook.Namespace
Set oNameSpace = Outlook.GetNamespace(“Mapi”)
Dim htmlBody As String
Dim fileAttach As Outlook.Attachment
Dim newMail As Outlook.MailItem
Set newMail = Outlook.CreateItem(olMailItem)
Dim text As String
Dim kol As Variant
Dim Mas1() As String
Dim Kol_Strok As Integer
Dim i As Integer
Dim text1 As String
Dim Signature As String
Dim SigString As String
‘Получение подписи напрямую
SigString = “c:\Users\Alex\AppData\Roaming\Microsoft\Signatures\Главная.htm”
‘Получение подписи через объектную структуру
Dim objFSO As Object, objTxtFile As Object, sFName As String
Set objFSO = CreateObject(“Scripting.FileSystemObject”)
‘Call InitSignPath
sFName = SigString
Set objTxtFile = objFSO.OpenTextFile(sFName, 1)
Signature = objTxtFile.ReadAll
objTxtFile.Close
‘MsgBox Signature
‘”<td style=’padding:10; width:200; align=right; valign=top’><img src=’C:\!!!!!!!!!!3_2017\Brief\hrizantemi-foto-03.jpg’ height=150></td></tr>” + _
Set fileAttach = Nothing ‘ освобождаем память
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
text1 = Selection.text
‘MsgBox text1
Dim k As Integer, k1 As Integer
Dim titul As String
‘Обработка первой строке для темы письма
k = InStr(1, text1, Chr(13))
k1 = InStr(1, text1, “<“)
‘MsgBox text1 + ” k= ” + CStr(k) + ” k1= ” + CStr(k1)
If k > 0 Then
titul = Mid(text1, 1, k – 1) + ” ” + Format(Date, “dd.mm.yyyy, dddd”)
End If
If k1 > 0 Then
titul = Mid(text1, 1, k1 – 1) + ” ” + Format(Date, “dd.mm.yyyy, dddd”)
Else
titul = “Отправлено ” + Format(Date, “dd.mm.yyyy, dddd”)
End If
newMail.Subject = titul
Call Добавить_BR_HTML ‘Замена символа конца абзаца на код переноса в HTML
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
text1 = Selection.text
‘MsgBox text1
‘ формируем тело письма. Таблица, два ряда – в верхнем одна -две картинки, в нижнем текст. Немного стиля и форматирования.
‘рисунки можно убрать , но обычно здесь располагают логотип. Количество строк можно изменить для упрощения кода. Основа кода не моя.
htmlBody = “<table align=’left’ style=’width:600;border:solid #316AA5 6.0pt;background=white;padding:0′>” + _
“<tr align=’center’>” + _
“<td style=’padding:10; width:30%; valign:top’></td>” + _
“<td width=’40%’><img src=’C:\!!!!!!!!!!3_2017\Brief\hrizantemi-foto-03.jpg’ height=100 width=100 align=’center’></td>” + _
“<td width=’30%’></td></tr>” + _
“<p><br><br>” + “</p>” + _
“<tr><td colspan=3 align=center>” + text1 + “</td>” + _
“<tr><td colspan=3 align=center>” + _
“<br><br>Благодарю за ваше внимание.<br><br><hr>С уважением!!!<br>” + _
“Рук. службы ИТ МОУ ДПО УМЦО<br>” + _
“Орехово-Зуевского района<br>” + _
“Чернолясов Ал-др Михайлович,<br>” + _
“тел. 8(496) 4-189-129,<br>” + _
“email: coozr1@yandex.ru,<br>” + _
“сайт: coozr1.narod.ru<br>” + _
“</td></tr></table>”
htmlBody = htmlBody ‘+ text1 ‘+ Signature – Добавление подписи через файл убрано
With newMail
‘.Subject = “Пример HTML файла – Отправлено ” + Format(Date, “dd.mm.yyyy, dddd”)
.To = “__ОУ_ООШ” ‘”coozr1@yandex.ru”
.BodyFormat = olFormatHTML
.htmlBody = htmlBody ‘ & String(8, vbCrLf) & Signature
.Display
.Send
End With
Set newMail = Nothing
Call Удалить_BR_HTML
Call Create_Brief_Html1 ‘(это тот же макрос, но с другим набором адресов)
End Sub
Успехов Вам!