CODEWITHSUNDEEP
vbaemailoutlook
dreojs16
dreojs16

Reputation: 117

Move Outlook incoming message to folder that starts with the same codes

I am trying to automate moving incoming messages to a designated subfolder in Outlook.

Messages that contain a projectnumber in the format P000.0000 should be moved to the Inbox's subfolder that starts with the same projectnumber.

The subfolders will be pre-created by hand, so the user can decide which projects to round up in a dedicated subfolder.

The folderstructure is Inbox>Actueel>P000.0000

The first bit, where incoming messages are checked works fine, but after that I get lost... Where it starts with For Each Folder In olFolderPrjcts

The error is on this line Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

This is what I came up with so far:

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

Upvotes: 0

Views: 69

Answers (1)

niton
niton

Reputation: 9179

Without Option Explicit the error is likely Run-time error '424': Object required.

With Option Explicit the error is likely Compile error: Variable not defined.

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

Upvotes: 1

Related Questions