Add new comment

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

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

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

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

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

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