Перемещение писем в подпапки на основе категорий

Question

В моем почтовом ящике есть подпапки, которые я использую для организации / хранения электронных писем. Моя структура папок выглядит следующим образом:

Входящие

-0день Входящие

-Matters

- 1. Название темы A

--- Клиент

---- Входящие

---- Sent

--- Внутренняя

---- Входящие

---- Sent

- 2. Название темы B

--- Клиент

---- Входящие

---- Sent

--- Внутренняя

---- Входящие

---- Sent

Общий процесс подачи заявок:

1) Все полученные электронные письма копируются в папку «0dayInbox» через правило. Это потому, что я хочу оставить копию всех писем в моем основном почтовом ящике.

2) Я просматриваю папку 0dayInbox и классифицирую электронные письма, основанные на разных темах (например, Тема A - Внутренняя часть или Тема A - Клиент), или, если они являются нежелательными сообщениями, помечаю их как категорию «Не для подачи».

3) У меня есть правила для перемещения писем, назначенных категориям, в определенные папки или, если они помечены как «Не для подачи», для их окончательного удаления. Например, если электронная почта относится к теме A - Внутренняя, то она перемещается в

Inbox --> Matters --> 1. Topic Name A --> Internal --> Inbox folder.

4) Мой Outlook имеет таймер, где каждые 3 часа он запускает правила над папкой 0dayInbox. Если ни одна категория не была назначена, электронная почта остается в папке 0dayInbox.

Вышеописанное работает отлично, за исключением того, что когда у меня появляются новые темы, я должен создавать новые правила. Я также не думаю, что выполнение правил обязательно является наиболее эффективным (иногда я жду минуты или около того, прежде чем оно завершится).

Мой код:

В модуле "ThisOutlookSession":

Private Sub Application_Quit()
  If TimerID <> 0 Then Call DeactivateTimer
End Sub

Private Sub Application_Startup()
    Call ActivateTimer(180)
End Sub

В обычном модуле:

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public TimerID As Long

Public Sub ActivateTimer(ByVal nMinutes As Long)
  nMinutes = nMinutes * 1000 * 60 
  If TimerID <> 0 Then Call DeactivateTimer
  TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
  If TimerID = 0 Then
    MsgBox "The timer failed to activate."
  End If
End Sub

Public Sub DeactivateTimer()
Dim lSuccess As Long
  lSuccess = KillTimer(0, TimerID)
  If lSuccess = 0 Then
    MsgBox "The timer failed to deactivate."
  Else
    TimerID = 0
  End If
End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)

    Dim objRules As Outlook.Rules
    Dim objRule As Outlook.Rule
    Dim olFolder  As Outlook.MAPIFolder
    Dim olNamespace As Outlook.NameSpace
    Set olNamespace = Application.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("0dayInbox")

    Set objRules = Outlook.Application.Session.DefaultStore.GetRules

    Set objRule = objRules.Item("Internal-Topic A")
    With objRule
        .Enabled = True
        .Execute ShowProgress:=True, Folder:=olFolder, IncludeSubfolders:=False
    End With

    Set objRule = objRules.Item("Client-Topic A")
    With objRule
        .Enabled = True
        .Execute ShowProgress:=True, Folder:=olFolder, IncludeSubfolders:=False
    End With

End Sub

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

Кажется, есть два альтернативных варианта:

1) Сохранение кода, как указано выше, но когда таймер запускает подпрограмму вместо запуска правил, он запускается через 0dayInbox и перемещает папки на основе категорий на основе серии If и Elseif (или в случае " Не для подачи ", навсегда удаляя их).

2) Удаление кода таймера и перемещение электронных писем при их категоризации.