Однажды мне надоело в каждом письме вводить: "Доброе утро, Иван", "Добрый день, Петр", и т.п. И решил я автомтизировать этот процесс.

Накидал себе небольшое техническое задание, которое содержало пункты:

1. До 12:00 пишем "доброе утро", с 12 до 18 - "добрый день", а после 18 - "добрый вечер".
2. Если получателей письма несколько, то обращаемся "коллеги".
3. Дополнительно проверяем, заполнена ли тема письма.
4. Обращаемся ко всем по сохраненному псевдониму.

И приступил к разработке макроса.

В итоге получиловь вот что:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

 

    Dim recip As Recipient

    Dim ii As Integer

    Dim Papkaest As Boolean

    Dim Privet As String

    Dim Privet_search As String

    Dim Privet_dlina As Integer

    Dim CurHaur As Integer

    

    ' Приветствие в зависимости от времени

    CurHour = DatePart("h", Now())

    If CurHour < 12 Then

        Privet = "Доброе утро, "

    ElseIf CurHour < 18 Then

        Privet = "Добрый день, "

    Else

        Privet = "Добрый вечер, "

    End If

    Privet_dlina = Len(Privet) - 1

    Privet_search = Left(Privet, Len(Privet) - 2) + "*"

    

    

    ' Добавляем слова приветствия в обращение,

    ' проверяем не добавлены ли уже слова с самого начала и после 2 энтеров

    If (Not Item.Body Like Privet_search) And _

    (Not Item.Body Like Chr(160) + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _

    Chr(160) + Chr(13) + Chr(10) + Chr(13) + Chr(10) + Privet_search) Then

        

        PrivetOrNot = MsgBox("Добавить приветствие?", vbYesNoCancel)

        If PrivetOrNot = vbNo Then

            GoTo exi

        ElseIf PrivetOrNot = vbCancel Then

            Cancel = True

            GoTo exi

        End If

        

        Dim Papka As Folder

        Dim zametka As NoteItem

        Dim Obr As String

        Dim isCollegue As Boolean

        

        ' Открываем папку заметок "Обращения"

        For Each Papka In Application.Session.GetDefaultFolder(olFolderNotes).Folders

            If Papka.Name = "Обращения" Then

                Papkaest = True

                Exit For

            End If

        Next

        

        ' Создаем папку заметок "Обращения", если ее нет

        If Not Papkaest Then

            If MsgBox("Папки " + Chr(34) + "Обращения" + Chr(34) + " нет. Без нее работа программы по добавлению приветствия невозможна. Создать такую?", vbYesNo) = vbYes Then

                Set Papka = Application.Session.GetDefaultFolder(olFolderNotes).Folders.Add("Обращения")

            Else

                GoTo exi

            End If

        End If

        

        ' Если получателей несколько, то обращаемся "коллеги"

        isCollegue = False

        CollegueCount = 0

        For Each recip In Item.Recipients

            If recip.Type = 1 Then

                CollegueCount = CollegueCount + 1

            End If

        Next

        If CollegueCount > 1 Then

            If MsgBox("В письме указано несколько получателей," _

            & vbNewLine & "обратиться к ним обобщенно «коллеги»?", vbYesNo) = vbYes Then isCollegue = True

        End If

        

        If isCollegue = True Then

        

            Privet = Privet + "коллеги, "

            

        Else

        

            For Each recip In Item.Recipients

                If recip.Type = 1 Then

                    

                    Dim pa As Outlook.PropertyAccessor

                    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

                    Obr = ""

                    

                    ' Определяем емайл текущего получателя

                    Set pa = recip.PropertyAccessor

                    'recipEmailAddress = recip.AddressEntry.Address

                    recipEmailAddress = pa.GetProperty(PR_SMTP_ADDRESS)

                    

                    ' Проверяем наличие обращения и присваиваем переменную Obr

                    For Each zametka In Papka.Items

                        If zametka.Body Like recipEmailAddress + "*" Then

                            Obr = Right(zametka.Body, Len(zametka.Body) - InStr(1, zametka.Body, "; ") - 1)

                            If InStr(1, Obr, "; ") <> 0 Then Obr = Left(Obr, InStr(1, Obr, "; ") - 1)

                            Exit For

                            'InStr(InStr(1,zametka.Body, "; ")+1,zametka.Body, "; ")

                        End If

                    Next

                    

                    ' Получяем приветствие, если его нет в заметках

                    If Obr = "" Then

                        ii = MsgBox("Нет имени для адресса: " + recipEmailAddress + "" _

                        & vbNewLine & "Да - отправить без имени," _

                        & vbNewLine & "Нет - попробовать найти имя в контактах," _

                        & vbNewLine & "Отмена - ввести имя вручную", vbYesNoCancel)

                        If ii = vbNo Then

                            'поиск

                            Dim oCont As ContactItem

                            For Each oCont In Application.Session.GetDefaultFolder(olFolderContacts).Items

                                If oCont.Class = olContact Then

                                    If oCont.Email1Address = recipEmailAddress _

                                    Or oCont.Email2Address = recipEmailAddress _

                                    Or oCont.Email3Address = recipEmailAddress Then

                                        Obr = oCont.FirstName + " " + oCont.MiddleName

                                        Exit For

                                    End If

                                End If

                            Next

                        End If

                        ' Добавляем заметку

                        Set zametka = Papka.Items.Add

                    Else

                        GoTo sliyan

                    End If

                        

                    ' Подтверждение правильности имени и внесение изменений в заметку

                    If Not ii = vbYes Then

                        Obr = InputBox("Введите имя, которое будет использоваться для адреса: " + _

                        recipEmailAddress, , Obr)

                    End If

                    If Obr = "" Then

                        If MsgBox("Отправить без добавления приветствия?", vbYesNo) = vbNo Then Cancel = True

                        zametka.Delete

                        GoTo exi

                    Else

                        zametka.Body = recipEmailAddress + "; " + Obr

                        zametka.Close olSave

                    End If

sliyan:

                    Privet = Privet + Obr + ", "

                End If

            Next

        

        End If

        

        ' Добавим восклицательный знак в конец

        Privet = Left(Privet, Len(Privet) - 2) + "!"

        

        ' Подставим союз "и" перед последним, если больше 1 имени соединено

        If InStrRev(Privet, ", ") > Privet_dlina Then _

        Privet = Left(Privet, InStrRev(Privet, ", ") - 1) + Replace(Privet, ", ", " и ", InStrRev(Privet, ", "))

       

        ' Добавление приветствия

        Item.BodyFormat = olFormatHTML

        Item.HTMLBody = "<p class=MsoNormal><span style='font-size:11.0pt;font-family:Calibri;color:#1F497D;'>" + Privet + "</span></p>" + Item.HTMLBody

 

        ' Оставим письмо без отправки чтобы юзер мог убедиться в правильном форматировании

        Cancel = True

        

    End If

 

exi:

 

    If Item.Subject = "" Then

        If Item.Attachments.Count > 0 Then Item.Subject = InputBox("Добавить тему", , Item.Attachments.Item(1).FileName)

        If Item.Subject = "" Then

            If MsgBox("Отправить без темы?", vbYesNo) = vbNo Then Cancel = True

        End If

    End If

 

End Sub

Как добавить этот макрос в MS Outlook?

1. Заходим в меню «Файл - Параметры - Настроить ленту» и включаем вкладку «Разработчик»:

2. Запускаем редактор Visual Basic в меню «Разработчик - Visual Basic»:

3. Вставляем код макроса в модуль «ThisOutlookSession»:

4. Создаем новое письмо, пишем текст, нажимаем кнопку «Отправить», программа спросит:

5. Нажимаем «Отмена», вводим псевдоним:

6. Письмо заполняется автоматически:

7. Все псевдонимы хранятся в специальной папке «Обращения» в Заметках:

Особая благодарность Константину Кузьмину.