Moving Emails from inbox to a subfolder

[samuelimtech]

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.


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






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

[gmayor]

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


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

[samuelimtech]

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


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.