Moving Emails from inbox to a subfolder

hi all,

first of all thanks for any help.

i've written a small script to read the subject from incoming emails and try to match it to a subfolder. For some reason the email isnt actually moved to the correct folder.

Code:

---

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace
 
  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
  Call MoveToFolder(Item)
 
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

---

Code:

---


Sub MoveToFolder(newmail As Outlook.MailItem)
On Error Resume Next






Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim i As Integer
Set objNS = GetNamespace("MAPI")
Dim SubFolder As Outlook.MAPIFolder
 
Set objFolder = objNS.Folders("xxx@xxxx.com).Folders("Inbox").Folders("Opportunities").Folders("Customers")


Dim subject As String
subject = newmail.subject
       
      For Each Item In objFolder.Folders
      If Item = "Birmingham" Then
      MsgBox ""
      End If
        'see if folder name is included in subject
        i = InStr(subject, Item)
        If i > 0 Then
            Set SubFolder = Inbox.Folders(Item)
            newmail.Move SubFolder 'email doesnt move
            Exit Sub
        End If
      Next
 
End Sub

---

You appear to have made up your own syntax for objFolder. The following should be closer

Code:

---

Sub MoveToFolder(newmail As Outlook.MailItem)
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder

    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox).folders("Opportunities").folders("Customers")
    For Each SubFolder In objFolder.folders
        If InStr(newmail.subject, SubFolder.Name) Then
            newmail.Move SubFolder
            Exit For
        End If
    Next
    Set objNS = Nothing
    Set objFolder = Nothing
    Set SubFolder = Nothing
End Sub

---

Quote:

---

Originally Posted by gmayor

You appear to have made up your own syntax for objFolder. The following should be closer

Code:

---

Sub MoveToFolder(newmail As Outlook.MailItem)
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder

    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox).folders("Opportunities").folders("Customers")
    For Each SubFolder In objFolder.folders
        If InStr(newmail.subject, SubFolder.Name) Then
            newmail.Move SubFolder
            Exit For
        End If
    Next
    Set objNS = Nothing
    Set objFolder = Nothing
    Set SubFolder = Nothing
End Sub

---

---

thanks Graham thats got it.