Outlook 2016. Обращение к адресату по имени

07 Dec
Published by Nicholas

Обращение к адресату по имени

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


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

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

Параметры Outlook

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

  Запуск редактора Visual Basic в MS Outlook

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

Макросы в Visual Basic

 

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

Если псевдоним не задан

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

  Вводим Псевдоним

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

  В письме заполняется обращение

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

  Псевдонимы храняться в заметказ, в папке "Обращения"

 

 

 

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

Файлы для скачивания: 

Тэги 

Outlook

Комментарии

Аватар пользователя Денис

Добрый день,
попробовал ваш код. В конце не хватало одного IF. Переносы строк "_" интерпретированы ка ошибки пришлось убрать. Далее появляется запрос на добавление приветствия,я его подтверждаю, но приветствие не добавляется, а далее письмо просто уходит без приветствия. У меня Windows 10 и Outlook 2016 (Office 360). Подскажите в чём может быть проблема?

Аватар пользователя Nicholas

Добавил в "Файлы для скачивания" файл "ThisOutlookSession.cls". Это экспорт полностью рабочего модуля, который я использую сейчас (Windows 10, Outlook 2016). Попробуйте загрузить его через меню "Файл - Импорт файла".

Аватар пользователя Сергей

Спасибо большое. Все работает. Импорт модуля и все как часики работает.

Аватар пользователя Денис

Не работает, ни код в тексте статьи (шипет ошибка как писали выше) ни импорт вашего вложения, письма остаются без изменений

Аватар пользователя Nicholas

Нужно смотреть отладчиком. Возможно код не совместим с вашей версией Аутлука (к сожалению, проверить не на чем). Какие вопросы задает программа перед отправкой письма и как вы на них отвечаете?

Аватар пользователя Даниил

Супер, то что нужно!
а можно сделать интеграцию с корпоративной адресной книгой?

Аватар пользователя Nicholas

Пожалуйста.

Я точно не буду этим заниматься, т.к. специализируюсь на другом направлении. Данный скрипт писал чисто для своего удобства, в свободное время.

Поищите специалиста, который специализируется на VB. Либо сами попробуйте. Если опыт программирования есть - должно получиться. Все языки программирования похожи.

Аватар пользователя Алексей

Я сделал таким образом
' получаем имя и отчество из глобального списка
Dim NameGlobal As String
NameGlobal = Mid(Item.To, InStr(Item.To, " ") + 1)

и перед строкой (' Получяем приветствие, если его нет в заметках) добавил
' Если нет сохраненного обращения - берем из глобального списка Имя и Отчество
If Obr = "" Then
Obr = NameGlobal
End If

Аватар пользователя Nicholas

Отличное решение, спасибо!

Аватар пользователя Гость

ОК

Аватар пользователя Сергей

С новым годом!
Nicholas можете скинуть образ оутлука 2016, под который вы делали . Обращение к адресату по имени
2245069@mail.ru

Аватар пользователя Nicholas

Добрый день, Сергей.

Спасибо за поздравления. Вас тоже с новым годом! К сожалению, образа у меня сейчас нет. Уверен, что его будет не сложно найти на просторах интернета.

Проверено скрипт работает на Outlook 2013 и 2016. Возможно и на более высоких версиях будет работать (не проверял).

Если на более свежих версиях скрипт будет выдавать ошибки, то его нужно будет просто доработать, если же вообще ничего не будет происходить, то нужно смотреть настройки безопасности и нужно будет разрешить запуск скриптов.

Аватар пользователя Сергей

Добрый день.
А можно выжимку приветствия по времени суток? (без имени)

Аватар пользователя Nicholas

Всё в ваших руках! :)

Аватар пользователя Сергей

Все работает, спасибо.

Аватар пользователя Денис

Спасибо! Отличный код.

Добавить комментарий

Plain text

  • HTML-теги не обрабатываются и показываются как обычный текст
  • Строки и абзацы переносятся автоматически.
CAPTCHA
Вы человек или автоматическая спам-рассылка?
Target Image