Как стать автором
Обновить

Автоматизация работы Microsoft Outlook с помощью VBA на примере создания массовой рассылки писем

Время на прочтение6 мин
Количество просмотров26K
В этой статье я бы хотел поделиться опытом автоматизации офисной, рутинной задачи по отправке сообщений группе клиентов.
Итак, собственно, в чем вопрос: необходимо отправить электронные письма с вложением нескольким десяткам клиентам. При этом в поле получателя должен быть только один адрес, т.е. клиенты друг о друге не должны знать. Кроме того, не допускается установка дополнительного программного обеспечения, типа 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.
Теги:
Хабы:
Всего голосов 14: ↑4 и ↓10-6
Комментарии16

Публикации

Истории

Ближайшие события