Рассылка писем через Outlook  с использованием макросов Word

Автор: | 26.10.2017

Рассылка писем через 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

Успехов Вам!

What are you working on?

Ваш адрес email не будет опубликован. Обязательные поля помечены *

Лимит времени истёк. Пожалуйста, перезагрузите CAPTCHA.