В этой статье я бы хотел поделиться опытом автоматизации офисной, рутинной задачи по отправке сообщений группе клиентов.
И так, собственно, в чем вопрос: необходимо отправить электронные письма с вложением нескольким десяткам клиентам. При этом в поле получателя должен быть только один адрес, т.е. клиенты друг о друге не должны знать. Кроме того, не допускается установка дополнительного программного обеспечения, типа MaxBulk Mailer и ему подобного. В нашем распоряжении есть только Microsoft Office, а в данном конкретном случае — Microsoft Office 2013.
Я описываю, на мой взгляд, самый вариант – без применения шаблонов, черновиков и форматирования. Для наших целей потребуется Outlook (переходим в редактор VBA и добавляем модуль, еще включаем «Microsoft Excel 15.0 Object Library» в Tools > References), текстовый файл со списком адресатов по принципу «одна строка-одни адрес», текстовый файл с телом письма и файлы, которые будем отправлять в качестве вложения.
Общий алгоритм таков: указываем данные для полей и генерируем письма, перебирая в цикле получателей.
Сразу отмечу, что данный пример не является неким доведенным до совершенства кодом, работающим с максимальной эффективностью при минимальных размерах. Но он работает и справляется с заявленным функционалом. Собственно, мне было просто лень отправлять вручную несколько десятков писем и я написал эту программу, а потом решил ей поделиться. Если кому-то интересно, тот может улучшать код сколько душе угодно.
VBA, по умолчанию, не требует четкого объявления переменных и их типов. В принципе, можно вообще обойтись без этого. Поэтому некоторые переменные в «эпизодических ролях» не описаны в конструкции с Dim.
И так, сначала запрашиваем тему письма с реализацией проверки на отмену действия.
TxtSubj = InputBox("Тема письма", "Рассылка")
If Len(Trim(TxtSubj)) = 0 Then
Exit Sub
End If
Теперь очередь за файлами с адресами и текстом письма. Вот здесь возник нюанс. Как вызвать диалог выбора файла? О жестком прописывании пути я не хочу и думать. Так что приходится что-то придумывать. Многими используемый вариант с Application.GetOpenFilename не пройдет, так как в Outlook нет такого метода. Использовать API пробовал. Вариант с «Private Declare PtrSafe Function GetOpenFileName Lib „comdlg32.dll“…» не сработал (PtrSafe из-за того, что система Win7, х64). Ошибок не выдавал, но при вызове ничего не появлялось. Решения в Интернете не нашел. Если кто подскажет решение – буду благодарен. Таким образом, пришлось пойти в обход с применением объекта Excel.Application.
Dim xlApp As New Excel.Application
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Файл с текстом письма"
.Filters.Add "Текстовый файл", "*.txt", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Path2Body = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Файл со списком адресов"
.Filters.Add "Текстовый файл", "*.txt", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Path2To = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
А теперь и вложения. Тут я использовал динамический массив и возможность множественного выбора диалога.
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
.Title = "Файлы, прилагаемые к письму"
.Filters.Add "Все файлы", "*.*", 1
If .Show = -1 Then
i = 0
ReDim Preserve Path2Att(i)
For Each vrtSelectedItem In .SelectedItems
Path2Att(i) = vrtSelectedItem
i = i + 1
ReDim Preserve Path2Att(i)
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
Каждый раз я создавал и удалял объект fd из-за того, что это сделать проще, чем заниматься его чисткой перед последующим вызовом.
Для получения данных из текстовых файлов пришлось использовать пару дополнительных функций. Вызываются они таким образом:
txtBody = ReadTXTfile(Path2Body)
Item2To = ReadTXTfile2Arr(Path2To)
Function ReadTXTfile(ByVal filename As String) As String
Set FSO = CreateObject("scripting.filesystemobject")
Set ts = FSO.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
Set ts = Nothing: Set FSO = Nothing
End Function
Function ReadTXTfile2Arr(ByVal filename As String) As Variant
Const OpenFileForReading = 1
Const OpenFileForWriting = 2
Const OpenFileForAppending = 8
Const vbSplitAll = -1
Dim S As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOFile = FSO.GetFile(filename)
Set TextStream = FSOFile.OpenAsTextStream(OpenFileForReading)
Do While Not TextStream.AtEndOfStream
S = S & TextStream.ReadLine & vbNewLine
Loop
TextStream.Close
ReadTXTfile2Arr = Split(S, vbNewLine, vbSplitAll, vbTextCompare)
Set TextStream = Nothing
Set FSOFile = Nothing
Set FSO = Nothing
End Function
С целью отладки я вставил такой код
'Контроль за данными
'Debug.Print "Адреса получателя"
'Debug.Print "-----------------"
'For i = 0 To UBound(Item2To) - 1
' Debug.Print Item2To(i)
'Next i
'Debug.Print "Прилагаемые файлы"
'Debug.Print "-----------------"
'For i = 0 To UBound(Path2Att) - 1
' Debug.Print Path2Att(i)
'Next i
'Debug.Print "Тема письма"
'Debug.Print "-----------"
'Debug.Print TxtSubj
'Debug.Print "Тело письма"
'Debug.Print "-----------"
'Debug.Print txtBody
Как видно, он сейчас закомментирован, но позволяет понять где что лежит.
Теперь небольшая по размеру, но самая важная часть – генерация писем.
Dim olMailMessage As Outlook.MailItem
For i = 0 To UBound(Item2To) - 1
Set olMailMessage = Application.CreateItem(olMailItem)
With olMailMessage
DoEvents
.To = Item2To(i)
.Subject = TxtSubj
.Body = txtBody
For k = 0 To UBound(Path2Att) - 1
.Attachments.Add Path2Att(k), olByValue
DoEvents
Next k
.Send
End With
Set olMailMessage = Nothing
Next i
При желании, метод .Send можно заменить на .Save. Тогда созданные письма окажутся в папке «Черновики».
Здесь полный код модуля «как есть».
Attribute VB_Name = "Module"
Function ReadTXTfile(ByVal filename As String) As String
Set FSO = CreateObject("scripting.filesystemobject")
Set ts = FSO.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
Set ts = Nothing: Set FSO = Nothing
End Function
Function ReadTXTfile2Arr(ByVal filename As String) As Variant
Const OpenFileForReading = 1
Const OpenFileForWriting = 2
Const OpenFileForAppending = 8
Const vbSplitAll = -1
Dim S As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOFile = FSO.GetFile(filename)
Set TextStream = FSOFile.OpenAsTextStream(OpenFileForReading)
Do While Not TextStream.AtEndOfStream
S = S & TextStream.ReadLine & vbNewLine
Loop
TextStream.Close
ReadTXTfile2Arr = Split(S, vbNewLine, vbSplitAll, vbTextCompare)
Set TextStream = Nothing
Set FSOFile = Nothing
Set FSO = Nothing
End Function
Public Sub Autosender()
'требуется текстовый файл с перечнем адресов (каждый с новой строки),
'текстовый файл с телом письма
'и попросит выбрать вложение (мультивыбор доступен)
Dim Path2Body As String
Dim Path2To As String
Dim Path2Att() As String
Dim Item2To() As String
Dim TxtSubj As String
Dim txtBody As Variant
Dim i
Dim k
Dim vrtSelectedItem As Variant
Dim fd As FileDialog
Dim olMailMessage As Outlook.MailItem
Dim xlApp As New Excel.Application
GenerateThis = False
TxtSubj = InputBox("Тема письма", "Рассылка")
If Len(Trim(TxtSubj)) = 0 Then
Exit Sub
End If
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Файл с текстом письма"
.Filters.Add "Текстовый файл", "*.txt", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Path2Body = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Файл со списком адресов"
.Filters.Add "Текстовый файл", "*.txt", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Path2To = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
.Title = "Файлы, прилагаемые к письму"
.Filters.Add "Все файлы", "*.*", 1
If .Show = -1 Then
i = 0
ReDim Preserve Path2Att(i)
For Each vrtSelectedItem In .SelectedItems
Path2Att(i) = vrtSelectedItem
i = i + 1
ReDim Preserve Path2Att(i)
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Set fd = Nothing
Set xlApp = Nothing
txtBody = ReadTXTfile(Path2Body)
Item2To = ReadTXTfile2Arr(Path2To)
DoEvents
'Контроль за данными
'Debug.Print "Адреса получателя"
'Debug.Print "-----------------"
'For i = 0 To UBound(Item2To) - 1
' Debug.Print Item2To(i)
'Next i
'Debug.Print "Прилагаемые файлы"
'Debug.Print "-----------------"
'For i = 0 To UBound(Path2Att) - 1
' Debug.Print Path2Att(i)
'Next i
'Debug.Print "Тема письма"
'Debug.Print "-----------"
'Debug.Print TxtSubj
'Debug.Print "Тело письма"
'Debug.Print "-----------"
'Debug.Print txtBody
For i = 0 To UBound(Item2To) - 1
Set olMailMessage = Application.CreateItem(olMailItem)
With olMailMessage
DoEvents
.To = Item2To(i)
.Subject = TxtSubj
.Body = txtBody
For k = 0 To UBound(Path2Att) - 1
.Attachments.Add Path2Att(k), olByValue
DoEvents
Next k
.Send
End With
Set olMailMessage = Nothing
Next i
MsgBox "Отправлено.", vbInformation + vbOKOnly, "Рассылка"
End Sub
В данном примере реализована возможность отправки простых писем. Если необходимо расширить возможности, например сделать текст форматированным, то двигаться следует в направлении Outlook.MailItem > GetInspector > WordEditor. Это, мягко говоря, усложняет код, но позволит использовать в качестве источника текста письма форматированный документ Word.
Можно также добавить обработку «преднамеренного» отсутствия каких-либо составляющих письма. Например, реализовать отправку без темы, текста или вложений. Сейчас отказ от одного из этих элементов приведет к прерыванию процедуры.
Этот код, теоретически, должен работать также и в более ранних версиях Microsoft Office. Поменяется только ссылка на библиотеку Excel.
Автор: KEugene
