How can I change this to run on sent items?
Sub Test()
Dim ns As Outlook.NameSpace
Dim objItem As Object
Dim FolderInbox As Folder
Dim MyItem As Outlook.MailItem
'// Added - A collection to hold the IDs of message to be deleted
Dim cMAILS As Collection
Set ns = Application.GetNamespace("MAPI")
Set FolderInbox = ns.GetDefaultFolder(olFolderInbox)
Set cMAILS = New Collection
For Each objItem In FolderInbox.Items
'// You need one block for each category...
If InStr(objItem.Categories, "SMT AGENDA") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 01 SMT")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "SMT TEAM LEADERS") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 02 TEAM LEADERS MEETING")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "COMMUNICATION") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 03 COMMUNICATION MEETING")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "CAROL MAITLAND") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 04 CAROL MAITLAND")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "MANAGEMENT") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 05 MANAGEMENT")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "ADP SUPPORT TEAM") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 01 ADP")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "BBV") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 02 BBV")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "CHILDRENS SERVICES") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 03 CPC CHILDRENS SERVICES")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "D&I") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 04 D&I")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "EARLIER INTERVENTION") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 05 DIRECT ACCESS")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "FINANCE") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 06 FINANCE")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "IAS") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 07 IAS REDESIGN")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "KEEPWELL") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 08 KEEPWELL")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "KEY PRIORITY") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 09 KEY AIM AND NALOXONE")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "MARYWELL") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 10 MARYWELL")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "PFR") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 11 PFR")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "QUALITY FRAMEWORK") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 12 QUALITY FRAMEWORK")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "RECOVERY") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 13 RECOVERY")
cMAILS.Add objItem.EntryID
End If
Next
On Error Resume Next
Do While cMAILS.count > 0
Set MyItem = ns.GetItemFromID(cMAILS(1))
If Not MyItem Is Nothing Then
MyItem.Delete
End If
cMAILS.Remove (1)
Loop
End Sub
Sub Test()
Dim ns As Outlook.NameSpace
Dim objItem As Object
Dim FolderInbox As Folder
Dim MyItem As Outlook.MailItem
'// Added - A collection to hold the IDs of message to be deleted
Dim cMAILS As Collection
Set ns = Application.GetNamespace("MAPI")
Set FolderInbox = ns.GetDefaultFolder(olFolderInbox)
Set cMAILS = New Collection
For Each objItem In FolderInbox.Items
'// You need one block for each category...
If InStr(objItem.Categories, "SMT AGENDA") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 01 SMT")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "SMT TEAM LEADERS") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 02 TEAM LEADERS MEETING")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "COMMUNICATION") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 03 COMMUNICATION MEETING")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "CAROL MAITLAND") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 04 CAROL MAITLAND")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "MANAGEMENT") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("AGENDAS 05 MANAGEMENT")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "ADP SUPPORT TEAM") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 01 ADP")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "BBV") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 02 BBV")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "CHILDRENS SERVICES") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 03 CPC CHILDRENS SERVICES")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "D&I") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 04 D&I")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "EARLIER INTERVENTION") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 05 DIRECT ACCESS")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "FINANCE") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 06 FINANCE")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "IAS") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 07 IAS REDESIGN")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "KEEPWELL") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 08 KEEPWELL")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "KEY PRIORITY") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 09 KEY AIM AND NALOXONE")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "MARYWELL") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 10 MARYWELL")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "PFR") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 11 PFR")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "QUALITY FRAMEWORK") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 12 QUALITY FRAMEWORK")
cMAILS.Add objItem.EntryID
ElseIf InStr(objItem.Categories, "RECOVERY") > 0 Then
Set MyItem = objItem.Copy
MyItem.Move FolderInbox.Folders("PROJECTS 13 RECOVERY")
cMAILS.Add objItem.EntryID
End If
Next
On Error Resume Next
Do While cMAILS.count > 0
Set MyItem = ns.GetItemFromID(cMAILS(1))
If Not MyItem Is Nothing Then
MyItem.Delete
End If
cMAILS.Remove (1)
Loop
End Sub