Переместить входящее сообщение Outlook в папку, которая начинается с тех же кодов

Question

Я пытаюсь автоматизировать перемещение входящих сообщений в указанную подпапку в Outlook.

Сообщения, содержащие номер проекта в формате P000.0000, следует переместить в подпапку «Входящие», которая начинается с того же номера проекта.

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

Структура папок - Входящие> Actueel> P000.0000

Первый бит, где проверяются входящие сообщения, работает нормально, но после этого я теряюсь ... Где он начинается с For Each Folder In olFolderPrjcts

Ошибка в этой строке Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

Это то, что я придумал до сих пор:

Private WithEvents myOlItems As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
      Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal item As Object)
  Dim Atts As Outlook.Attachments
  Dim Props As Outlook.UserProperties
  Dim Prop As Outlook.UserProperty
  Dim PropName As String

  PropName = "NumberAttachments"

  Set Atts = item.Attachments
  Set Props = item.UserProperties
  Set Prop = Props.Find(PropName, True)
  If Prop Is Nothing Then
    Set Prop = Props.Add(PropName, olText, True)
  End If

  Dim olFolder As Outlook.MAPIFolder
  Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

  Dim olFolderPrjcts
  Set olFolderPrjcts = olFolder.Folders("actueel")

  Prop.Value = Atts.Count
  item.Save

  Dim Msg As Outlook.MailItem

  If TypeName(item) = "MailItem" Then
    Set Msg = item

    For Each Folder In olFolderPrjcts
        If Left(Msg.Subject, 9) = Left(Folder.Name, 9) Then
            Msg.Move (Folder)
        End If
    Next
' DO SOMETHING TO NEWLY ARRIVED MESSAGE
'     If Msg.Subject contains like P000.0000 AND
'       folder exists that starts with P000.0000
'       then move to that folder

  End If

End Sub

Answer 1

Без опции Явная ошибка, скорее всего, ошибка во время выполнения '424': требуется объект.

С опцией Явная ошибка, скорее всего, ошибка компиляции: переменная не определена.

Option Explicit

' Tools | Options | Editor tab
' Checkbox "Require Variable Declaration"

Private Sub myOlItems_ItemAdd(ByVal Item As Object)

    Dim objNS As Namespace  ' <--

    Dim olFolder As folder
    Dim folder As folder
    Dim olFolderPrjcts As folder

    Dim Msg As MailItem

    Set objNS = GetNamespace("MAPI")    ' <--

    Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    Set olFolderPrjcts = olFolder.Folders("actueel")

    If TypeName(Item) = "MailItem" Then

        Set Msg = Item

        For Each folder In olFolderPrjcts.Folders
            If Left(Msg.subject, 9) = Left(folder.name, 9) Then
                'Debug.Print Msg.subject
                'Debug.Print folder.name
                Msg.move folder ' <-- no brackets
                Exit For
            End If
        Next

  End If

End Sub