#Const LateBinding = True
'this subroutine addes the category "Email Copied" to all item in the input Folder
#If LateBinding Then
Private Sub MarkAsDistributed(ByRef Folder As Object)
Dim Item As Object
#Else
Private Sub MarkAsDistributed(ByRef Folder As Outlook.MAPIFolder)
Dim Item As Outlook.MailItem
#End If
For Each Item In Folder.Items
If Not Item.Categories = "Email Copied" Then
Item.Categories = "Email Copied"
Item.Save
End If
Next Item
End Sub
'this function determines where a category with the name CategoryName exist in the name space NS
#If LateBinding Then
Private Function CategoryExists(ByRef NS As Object, CategoryName As String) As Boolean
Dim cat As Object
#Else
Private Function CategoryExists(ByRef NS As Outlook.NameSpace, CategoryName As String) As Boolean
Dim cat As Outlook.Category
#End If
CategoryExists = False
If NS.Categories.Count = 0 Then
Exit Function
End If
' Enumerate the Categories collection.
For Each cat In NS.Categories
If cat.Name = CategoryName Then
CategoryExists = True
End If
Next
Set cat = Nothing
End Function
'this subroutine copies all of the items in the SourceFolder to the DestinationFolder if the item in the SourceFolder
'do not have the category "Email Copied"
#If LateBinding Then
Private Sub CopyAllItems(ByRef SourceFolder As Object, ByRef DestinationFolder As Object)
Dim Item As Object
Dim Copy As Object
#Else
Private Sub CopyAllItems(ByRef SourceFolder As Outlook.MAPIFolder, ByRef DestinationFolder As Outlook.MAPIFolder)
Dim Item As Outlook.MailItem
Dim Copy As Outlook.MailItem
#End If
For Each Item In SourceFolder.Items
If Not Item.Categories = "Email Copied" Then
Set Copy = Item.Copy
Copy.Move DestinationFolder
End If
Next Item
Set Copy = Nothing
End Sub
'main program to copy email from the Inbox folder to other folders
Public Sub DistributeEmails()
#If LateBinding Then
Dim OutLookApp As Object
Dim NS As Object
Dim SourceFolder As Object
Dim DestFolder As Object
Const olCategoryColorTeal = 6
#Else
Dim OutLookApp As Outlook.Application
Dim NS As Outlook.NameSpace
Dim SourceFolder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
#End If
Set OutLookApp = CreateObject("Outlook.Application")
Set NS = OutLookApp.GetNamespace("MAPI")
'this ensures the name space has the category "Email Copied"
If Not CategoryExists(NS, "Email Copied") Then
'see https://msdn.microsoft.com/en-us/library/office/ff860420.aspx for possible colors
NS.Categories.Add "Email Copied", olCategoryColorTeal
End If
'add source folder here
Set SourceFolder = NS.Folders("Personal Folders").Folders("Inbox")
'add destination folders here
Set DestFolder = NS.Folders("Personal Folders").Folders("paul")
CopyAllItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("james")
CopyAllItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("john")
CopyAllItems SourceFolder, DestFolder
MarkAsDistributed SourceFolder
MsgBox "Items have been copied"
Set NS = Nothing
Set SourceFolder = Nothing
Set DestFolder = Nothing
End Sub
