Automating Microsoft Outlook with VBA using the example of creating mass mailing

In this article, I would like to share the experience of automating the office, routine task of sending messages to a group of clients.
So, actually, what is the question: you need to send emails with an attachment to several dozens of customers. In this case, the recipient field must contain only one address, i.e. customers should not know about each other. In addition, it is not allowed to install additional software such as MaxBulk Mailer and the like. We have only Microsoft Office at our disposal, and in this particular case, Microsoft Office 2013.

I describe, in my opinion, the most option - without the use of templates, drafts and formatting. For our purposes, we need Outlook (go to the VBA editor and add the module, we also include the “Microsoft Excel 15.0 Object Library” in Tools> References), a text file with a list of recipients on the principle of “one line, one address”, a text file with the body of the letter and files that we will send as an attachment.
The general algorithm is as follows: specify the data for the fields and generate letters, sorting through the recipients in a loop.
Immediately, I note that this example is not some kind of perfected code that works with maximum efficiency with minimum size. But it works and copes with the declared functionality. Actually, I was just too lazy to manually send several dozen letters and I wrote this program, and then decided to share it. If anyone is interested, he can improve the code as much as he wants.
VBA, by default, does not require a clear declaration of variables and their types. In principle, you can do without it at all. Therefore, some variables in "episodic roles" are not described in the construction with Dim.
So, first we request the subject of the letter with the implementation of the check for the cancellation of the action.
TxtSubj = InputBox("Тема письма", "Рассылка")
If Len(Trim(TxtSubj)) = 0 Then
    Exit Sub
End If

Now it’s the turn of the file with the addresses and text of the letter. Here a nuance arose. How to call the file selection dialog? I don’t want to think about hard way prescribing. So you have to come up with something. Many people use the option with Application.GetOpenFilename will not work, because in Outlook there is no such method. I tried to use the API. The option with "Private Declare PtrSafe Function GetOpenFileName Lib" comdlg32.dll "..." did not work (PtrSafe due to the Win7, x64 system). I didn’t issue errors, but nothing appeared during the call. I did not find a solution on the Internet. If someone prompts a solution - I will be grateful. Thus, I had to bypass using the Excel.Application object.
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

And for another file
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


And now the investment. Here I used a dynamic array and the ability to select multiple dialogs.
The code
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


Each time I created and deleted the fd object because it was easier to do than to clean it before the next call.
To get data from text files, I had to use a couple of additional functions. They are called this way:
txtBody = ReadTXTfile(Path2Body)
Item2To = ReadTXTfile2Arr(Path2To)

And here is their source code
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


For the purpose of debugging, I inserted the code
'Data Control
'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

As you can see, it is now commented out, but allows you to understand where what lies.
Now small, but the most important part is the generation of letters.
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

If desired, the .Send method can be replaced with .Save. Then the created letters will appear in the Drafts folder.

Here is the complete module code "as is".
The code
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



This example implements the ability to send simple letters. If you need to expand opportunities, for example, to make text formatted, then you should move in the direction of Outlook.MailItem> GetInspector> WordEditor. This, to put it mildly, complicates the code, but allows you to use a formatted Word document as the source of the message text.
You can also add processing to the “intentional” absence of any components of the letter. For example, implement sending without a subject, text or attachments. Failure of one of these elements will interrupt the procedure.
This code, theoretically, should also work in earlier versions of Microsoft Office. Only the link to the Excel library will change.

Also popular now: