问宏在主题包含时将msg移动到文件夹。

EN

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