Однажды мне надоело в каждом письме вводить: «Доброе утро, Иван», «Добрый день, Петр», и т.п. И решил я автомтизировать этот процесс.
Накидал себе небольшое техническое задание, которое содержало пункты:
- До 12:00 пишем «доброе утро», с 12 до 18 — «добрый день», а после 18 — «добрый вечер».
- Если получателей письма несколько, то обращаемся «коллеги».
- Дополнительно проверяем, заполнена ли тема письма.
- Обращаемся ко всем по сохраненному псевдониму.
И приступил к разработке макроса.
В итоге получиловь вот что:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
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 CurHour 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. Все псевдонимы хранятся в специальной папке «Обращения» в Заметках:
Особая благодарность Константину Кузьмину.
Экспорт модуля
Добрый день,
попробовал ваш код. В конце не хватало одного IF. Переносы строк «_» интерпретированы ка ошибки пришлось убрать. Далее появляется запрос на добавление приветствия,я его подтверждаю, но приветствие не добавляется, а далее письмо просто уходит без приветствия. У меня Windows 10 и Outlook 2016 (Office 360). Подскажите в чём может быть проблема?
Добавил в «Файлы для скачивания» файл «ThisOutlookSession.cls». Это экспорт полностью рабочего модуля, который я использую сейчас (Windows 10, Outlook 2016). Попробуйте загрузить его через меню «Файл — Импорт файла».
Спасибо большое. Все работает. Импорт модуля и все как часики работает.
Не работает, ни код в тексте статьи (шипет ошибка как писали выше) ни импорт вашего вложения, письма остаются без изменений
Нужно смотреть отладчиком. Возможно код не совместим с вашей версией Аутлука (к сожалению, проверить не на чем). Какие вопросы задает программа перед отправкой письма и как вы на них отвечаете?
Супер, то что нужно!
а можно сделать интеграцию с корпоративной адресной книгой?
Пожалуйста.
Я точно не буду этим заниматься, т.к. специализируюсь на другом направлении. Данный скрипт писал чисто для своего удобства, в свободное время.
Поищите специалиста, который специализируется на VB. Либо сами попробуйте. Если опыт программирования есть — должно получиться. Все языки программирования похожи.
Я сделал таким образом
‘ получаем имя и отчество из глобального списка
Dim NameGlobal As String
NameGlobal = Mid(Item.To, InStr(Item.To, » «) + 1)
и перед строкой (‘ Получяем приветствие, если его нет в заметках) добавил
‘ Если нет сохраненного обращения — берем из глобального списка Имя и Отчество
If Obr = «» Then
Obr = NameGlobal
End If
Отличное решение, спасибо!
ОК
С новым годом!
Nicholas можете скинуть образ оутлука 2016, под который вы делали . Обращение к адресату по имени
2245069@mail.ru
Добрый день, Сергей.
Спасибо за поздравления. Вас тоже с новым годом! К сожалению, образа у меня сейчас нет. Уверен, что его будет не сложно найти на просторах интернета.
Проверено скрипт работает на Outlook 2013 и 2016. Возможно и на более высоких версиях будет работать (не проверял).
Если на более свежих версиях скрипт будет выдавать ошибки, то его нужно будет просто доработать, если же вообще ничего не будет происходить, то нужно смотреть настройки безопасности и нужно будет разрешить запуск скриптов.
Добрый день.
А можно выжимку приветствия по времени суток? (без имени)
Всё в ваших руках! 🙂
Все работает, спасибо.
Спасибо! Отличный код.
Спасибо за статью. С новым 2025 годом!
Вместо последней строки «End If» блока:
‘ Добавляем слова приветствия в обращение,
‘ проверяем не добавлены ли уже слова с самого начала и после 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
Ставим «ElseIf PrivetOrNot = vbYes Then»
‘ Добавляем слова приветствия в обращение,
‘ проверяем не добавлены ли уже слова с самого начала и после 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
ElseIf PrivetOrNot = vbYes Then
И заработало, но так и не подтягивает с адресной книги имя и отчество хотя элементы такие есть и в карточке заполнены.
Помогло решение Виталия, вставил вместо блока поиск его код. Но маленько поломал генерацию заметок, тянет сразу оба И.О.
Версия outlook 14.07268.5000(64) из 10го офиса.
Спасибо, что поделились!