Добавить категории в входящие письма с помощью VBA

Question

Я пытаюсь написать код VBA в Outlook 2003, который будет добавлять категории к электронной почте при отправке, так что ответ появится с автоматически добавленными категориями. Это упрощает подачу ответов.

Например, если я отправляю электронное письмо, отвечающее всем, ответ в моем почтовом ящике идеально будет отображаться с категорией автоматически как «~ Ответить». В настоящее время все ответы я вручную классифицирую как таковые.

Помогите с этим кодом? Я видел, как удалить категории с этого форума, но я пытаюсь добавить его.

Answer 1

У меня нет средств для проверки этого с общим почтовым ящиком, но я надеюсь, что следующее поможет.

Исследователь VBA редактора перечислит структуру, как это:

- Project 1 (VbaProject.OTM) 
    + Microsoft Office Outlook Objects 
    + Forms 
    + Modules 

Нажмите на + против Microsoft Office Outlook Objects получить

- Project 1 (VbaProject.OTM) 
    - Microsoft Office Outlook Objects 
    + ThisOutlookSession 
    + Forms 
    + Modules 

Все ниже код должен быть помещен в ThisOutlookSession модуля.

Первая процедура (Application_Startup) вызывается при открытии Outlook.

Option Explicit 
Public UserName As String 
Public WithEvents MyNewItems As Outlook.Items 
Private Sub Application_Startup() 

    ' This event procedure is called when Outlook is started 

    Dim NS As NameSpace 

    Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI") 

    With NS 
    UserName = .CurrentUser 
    Set MyNewItems = NS.GetDefaultFolder(olFolderInbox).Items 
    End With 

    MsgBox "Welcome " & UserName 

End Sub 

В приведенном выше коде есть два отдельных вида деятельности.

Во-первых, он устанавливает UserName = .CurrentUser. Когда я запускаю приведенный выше код, UserName устанавливается на мое имя пользователя. Я предполагаю, что то же самое будет с вами и вашими коллегами, чтобы макрос ниже мог знать, какой пользователь является текущим пользователем. Обратите внимание, что пользователю необходимо будет предоставить разрешение для доступа к макросу .CurrentUser. Вы можете использовать InputBox для получения инициалов пользователя.

Во-вторых, он инициализирует MyNewItems. Это позволяет мне указать обработчик событий для добавления новых элементов в папку «Входящие».

Следующая процедура (Application_ItemSend) вызывается после нажатия кнопки Отправить buttom и до отправки сообщения. Вы можете изменить или добавить сообщение. Вы можете даже отменить отправку с Cancel = False.

Я использовал эту процедуру для вывода возможных полезных свойств в окно Immediate.

Согласно моим экспериментам, любые категории, которые вы установили, записываются в версии отправленных товаров, но не в версии, отправленной получателю. Поэтому они не могут быть в ответе, даже если другая сторона использует Outlook.

Одним из вариантов было бы добавить код в конце темы. Другой вариант - установить .ReplyRecipients на другой адрес. Сообщение по-прежнему будет отправлено из группы «Входящие», но любой ответ перейдет к .ReplyRecipients.

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

    ' This event procedure is called when the Send button is clicked but 
    ' before the item is sent. 

    Dim Inx As Long 

    Debug.Print "------Item Send" 

    ' Note this routine operate on all items not just mail items. 
    ' See "myNewItems_ItemAdd" for a method of restricting the 
    ' routine to mail items 

    With Item 

    .Subject = .Subject & " (xyz1)" 
    Debug.Print "Subject " & .Subject 

    For Inx = 1 To .Recipients.Count 
     Debug.Print "Recipient " & .Recipients(Inx).Name 
    Next 

    ' Remove any existing reply recipients 
    Do While .ReplyRecipients.Count > 0 
     .ReplyRecipients.Remove 1 
    Loop 

    .ReplyRecipients.Add "JohnSmith@Company.com" 

    End With 

End Sub 

Последняя инструкция (myNewItems_ItemAdd) обрабатывает новые почтовые отправления. В текущем коде не действуют другие элементы, такие как запросы на собрания. Этот код ничего не делает, но выводит объект в окно Immediate. Однако вы можете переместить сообщение в другую папку.

Private Sub myNewItems_ItemAdd(ByVal Item As Object) 

    ' This event procedure is called whenever a new item is added to 
    ' to the InBox. 

    Dim NewMailItem As MailItem 

    Debug.Print "------Item Received" 

    On Error Resume Next 
    ' This will give an error and fail to set NewMailIten if 
    ' Item is not a MailItem. 
    Set NewMailItem = Item 
    On Error GoTo 0 

    If Not NewMailItem Is Nothing Then 
    ' This item is a mail item 
    With NewMailItem 
     Debug.Print .Subject 
    End With 
    Else 
    ' Probably a meeting request. 
    Debug.Print "Not mail item " & Item.Subject 
    End If 

End Sub 

Надеюсь, что вышеизложенное дает вам некоторые идеи.