CODEWITHSUNDEEP
vbaoutlookoutlook-2013
DigitalSea
DigitalSea

Reputation: 191

Macro to move msg to folder when subject contains

I'm working with the code below. It works sometimes. I mean I can run test emails and it does what it supposed to do, but sometimes I get errors: The two errors I have gotten so far are: "Operation Failed. Object could not be found." And "Instant Search Not Enabled on Store." It appears to be random. My question is how can I enhance the code to make sure it runs without getting these errors??? I have the code programmed to fire every minute. Thanks 

Option Explicit

Sub MoveItems()

Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolderWA As Outlook.Folder
Dim myDestFolderOR As Outlook.Folder
Dim myDestFolderID As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItemWA As Object
Dim myItemOR As Object
Dim myItemID As Object
Dim strFilter1 As String
Dim strFilter2 As String
Dim strFilter3 As String
Dim RestrictItems As Outlook.Items
Dim Mail As Outlook.MailItem

On Error GoTo ErrHandler

Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders("Subpayables Invoices").Folders("Inbox")
Set myItems = myInbox.Items

Set myDestFolderWA = myInbox.Folders("WA")
Set myDestFolderOR = myInbox.Folders("OR")
Set myDestFolderID = myInbox.Folders("ID")


strFilter1 = "@SQL=" & Chr(34) _
& "urn:schemas:httpmail:subject" & Chr(34) _
& " ci_phrasematch 'washington'"

strFilter2 = "@SQL=" & Chr(34) _
& "urn:schemas:httpmail:subject" & Chr(34) _
& " ci_phrasematch 'oregon'"

strFilter3 = "@SQL=" & Chr(34) _
& "urn:schemas:httpmail:subject" & Chr(34) _
& " ci_phrasematch 'idaho'"


Set RestrictItems = myItems.Restrict(strFilter1)
Set myItemWA = RestrictItems.GetFirst

Set RestrictItems = myItems.Restrict(strFilter2)
Set myItemOR = RestrictItems.GetFirst

Set RestrictItems = myItems.Restrict(strFilter3)
Set myItemID = RestrictItems.GetFirst

While TypeName(myItemWA) <> "Nothing"
myItemWA.Move myDestFolderWA
Set myItemWA = RestrictItems.GetNext
Wend

While TypeName(myItemOR) <> "Nothing"
myItemOR.Move myDestFolderOR
Set myItemOR = RestrictItems.GetNext
Wend

While TypeName(myItemID) <> "Nothing"
myItemID.Move myDestFolderID
Set myItemID = RestrictItems.GetNext
Wend
Exit Sub

ErrHandler:
MsgBox Err & ": " & Error(Err)

End Sub

Upvotes: 0

Views: 1356

Answers (1)

Eugene Astafiev
Eugene Astafiev

Reputation: 49397

I am not getting any errors, but it is not doing what I want it to do

Did you try to debug the code and see what happens there? Do you get any errors?

The ItemAdd event of the Items class does not run when a large number of items are added to the folder at once (more than 16). This is a well-known issue. Is that the case?

You may consider handling the NewMailEx event of the Application class which is fired when a new item is received in the Inbox. Here is what MSDN states:

The NewMailEx event fires when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item. Use this method with caution to minimize the impact on Outlook performance. However, depending on the setup on the client computer, after a new message arrives in the Inbox, processes like spam filtering and client rules that move the new message from the Inbox to another folder can occur asynchronously. You should not assume that after these events fire, you will always get a one-item increase in the number of items in the Inbox.

Upvotes: 1

Related Questions