Создать новую папку для нового имени отправителя и переместить сообщение в новую папку

Question

Фон

Я бы хотел, чтобы Outlook 2010 автоматически перемещал электронные письма в папки, обозначенные именем человека. Например:

1. Нажмите Правила
2. Нажмите Управление правилами и оповещениями
3. Нажмите Новое правило
4. Выберите «Переместить сообщения от кого-либо в папку»
5. Нажмите кнопку "Далее

Отображается следующий диалог:

проблема

Следующая часть обычно выглядит следующим образом:

1. Нажмите people or public group
2. Выберите желаемого человека
3. Нажмите specified
4. Выберите нужную папку

Вопрос

Как бы вы автоматизировали эти проблемные ручные задачи? Вот логика для нового правила, которое я хотел бы создать:

1. Получите новое сообщение.
2. Извлеките имя отправителя.
3. Если он не существует, создайте новую папку в папке «Входящие»
4. Переместить новое сообщение в папку, назначенную имени этого человека

Я думаю, что для этого потребуется макрос VBA.

Ссылки по теме

• http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/A_420-Extending-Outlook-Rules-via-Scripting.html
• http://msdn.microsoft.com/en-us/library/office/ee814735.aspx
• http://msdn.microsoft.com/en-us/library/office/ee814736.aspx
• https://stackoverflow.com/questions/11263483/how-do-i-trigger-a-macro-to-run-after-a-new-mail-is-received-in-outlook
• http://en.kioskea.net/faq/6174-outlook-a-macro-to-create-folders
• http://blogs.iis.net/robert_mcmurray/archive/2010/02/25/outlook-macros-part-1-moving-emails-into-personal-folders.aspx

Обновление № 1

Код может напоминать что-то вроде:

Public WithEvents myOlApp As Outlook.Application

Sub Initialize_handler()
    Set myOlApp = CreateObject("Outlook.Application")
End Sub

Private Sub myOlApp_NewMail()
    Dim myInbox As Outlook.MAPIFolder
    Dim myItem As Outlook.MailItem

    Set myInbox = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set mySenderName = myItem.SenderName

    On Error GoTo ErrorHandler
    Set myDestinationFolder = myInbox.Folders.Add(mySenderName, olFolderInbox)

    Set myItems = myInbox.Items
    Set myItem = myItems.Find("[SenderName] = " & mySenderName)
    myItem.Move myDestinationFolder

ErrorHandler:
    Resume Next
End Sub

Обновление № 2

Разделите код следующим образом:

Отправил тестовое сообщение и ничего не произошло. Инструкции по фактическому запуску сообщения при поступлении нового сообщения немного освещают детали (например, не упоминается ни о ThisOutlookSession , ни о том, как его использовать).

Спасибо.

Answer 1

Я бы забыл полностью использовать правила и вместо этого создать макрос VBA, который прикреплен к событию NewMail, и создаст папку (используя папки.Добавьте метод) на основе свойства SenderName, а затем переместите его туда с помощью метода Move объекта MailItem.

Answer 2

На этот часто задаваемый вопрос ответили здесь.

http://www.jpsoftwaretech.com/automatically-triage-emails-by-sender-name/

Использует ItemAdd, чтобы делать то, что будет делать Newmail, теперь NewMailEx.

В модуле ThisOutlookSesion

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

  ' set object reference to default Inbox
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String

  ' don't do anything for non-Mailitems
  If TypeName(item) <> "MailItem" Then GoTo ProgramExit

  Set Msg = item

  ' move received email to target folder based on sender name
  senderName = Msg.senderName

  If CheckForFolder(senderName) = False Then  ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = _
    objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
  End If

  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error Goto 0

If Not FolderTocheck Is Nothing Then
  CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function