Option Explicit
Dim moveToFolder As Outlook.MAPIFolder
Dim searchItems As Items
Dim msg As MailItem
Dim foundFlag As Boolean
Dim i As Long
Dim c As Long
Dim z As Long
Dim unreadmessagesininbox As String
Dim totalmessagesininbox As String
Dim NS As Outlook.Namespace
Dim searchFolder As Outlook.MAPIFolder
Dim pos As Integer 'used to help get job number from subject line
Dim jnum As String ' is the job number
Dim jcq As String ' is the controllers queue
Dim counter1
Dim counter2 ' used to help deal with email were there is no controller ‘ added 14.01.15
Dim tarrget As String
Dim subj As String
Dim re As Object
Dim match As Variant
Sub moveemail()
' In the Visual Basic Editor (VBE)
' Tools menu | References...
' Tick the entry for
' Microsoft VBScript Regular Expressions 5.5
' &
' microsoft outlook 12.0 object libary
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
counter1 = 0 'used if the subject line does not contain a job number
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
On Error Resume Next ' To bypass the error when the source folder is not found.
' searchFolder will be Nothing
' Enter the exact names of the folders
' No slashes. Walk the path one folder at a time.
Set searchFolder = NS.Folders("mouth G").Folders("Inbox")
On Error GoTo 0
If searchFolder Is Nothing Then
MsgBox "Source folder not found!", vbOKOnly + vbExclamation, "searchSubject error"
GoTo ExitRoutine
Else
Debug.Print vbCr & "searchFolder: " & searchFolder
End If
'unreadmessagesininbox = searchFolder.UnReadItemCount 'counts the number of unread emails in inbox
'MsgBox ("unread messages = " & unreadMessagesInInbox)
'totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
'MsgBox (" total messages = " & TotalmessagesInInbox)
'''''''''''''''''''''''''''''''''''''
'For Each oMail In searchFolder.Items
'If oMail.UnRead Then
'oUnread = oUnread + 1 ' this gets number of unread emails
'Else
'oread = oread + 1 ' this gets number of read emails
'End If
'Next
'MsgBox ("read messages = " & oread)
'''''''''''''''''''''''''''''''''''''''
Set searchItems = searchFolder.Items
For i = searchItems.Count To 1 Step -1
If searchItems(i).Class = olMail Then
Set msg = searchItems(i)
patternabcd123456 msg, foundFlag
If foundFlag = True Then
Debug.Print " Move this mail: " & searchItems(i)
If searchItems(i).UnRead = False Then
searchItems(i).UnRead = True ' if email has been read changes it to unread
End If
Call whattodonow
If counter2 = 1 Then
GoTo nextemail
End If
''''''''''''''''''''''''''''''''
searchItems(i).Move moveToFolder: ScrnChk
End If
End If
nextemail:
Next
ExitRoutine:
totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
MsgBox (totalmessagesininbox & " E-mails remain in the inbox, please check manually")
Set msg = Nothing
Set searchItems = Nothing
Set searchFolder = Nothing
Set NS = Nothing
Call quitexcel
End Sub
Sub patternabcd123456(MyMail As MailItem, fndFlag)
fndFlag = False
subj = MyMail.Subject
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If subj = "*** Important - Please Read - Daily Tracker Reports and Systems Issues ***" Or subj = "Auto Response" Then
pos = InStrRev(subj, "ONE"): ScrnChk 'can "ONE" be removed
If pos = "0" Then ' not found
pos = InStrRev(subj, "OSA")
End If
If pos = "0" Then
pos = InStrRev(subj, "TBA")
End If
If pos = "0" Then
pos = InStrRev(subj, "TWE")
End If
If pos = "0" Then
pos = InStrRev(subj, "TSA")
End If
If pos > 0 Then
GoTo jobnumber
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'added 27.01.16
If pos = "0" Then 'job number etc not found
pos = InStrRev(subj, "*** Important - Please Read - Daily Reports and Systems Issues ***"): ScrnChk
End If
If pos = "0" Then 'onea etc not found
pos = InStrRev(subj, "Auto Response"): ScrnChk
'pos = InStrRev(subj, "Auto Response")
'pos = 0
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If pos > 0 Then
'If pos > 0 And subj = "*** Important - Please Read - Tracker Reports and Systems Issues ***" Or subj = "Auto Response" Then
'move to deleted folder
End If
jobnumber:
jnum = Mid(subj, pos, 10): ScrnChk
Else
If pos = 0 Then
counter2 = 1
Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End If
Set re = CreateObject("vbscript.regexp")
re.Pattern = jnum
For Each match In re.Execute(subj)
fndFlag = True
Debug.Print vbCr & subj
Debug.Print " *** Pattern found: " & match
Next
Set re = Nothing
End Sub
1. I don’t want to copy and move all emails. Only those that have a certain word in the subject line
2. Any email copied/placed into the other folders needs to be removed/deleted from the source folder.
jnum = Mid(subj, pos, 10)
Debug.Print " Move this mail: " & searchItems(i)
Debug.Print " Move this mail: " & searchItems(i).Subject
MarkForDistribution SourceFolder, "Deemed", "DEEMED"
#Const LateBinding = True
'this subroutine marks the items in the Folder that have any of the KeyWords in the subject
#If LateBinding Then
Private Sub MarkForDistribution(ByRef Folder As Object, ParamArray KeyWords())
Dim Item As Object
#Else
Private Sub MarkForDistribution(ByRef Folder As Outlook.MAPIFolder, ParamArray KeyWords())
Dim Item As Outlook.MailItem
#End If
Dim word As Variant
For Each Item In Folder.Items
For Each word In KeyWords
If InStr(1, Item.Subject, word) > 0 Then
Item.Categories = "Needs Distribution"
Item.Save
End If
Next word
Next Item
End Sub
'this subroutine deletes (moves to the Delete folder)the items in the Folder that have the category ""Needs Distribution"
#If LateBinding Then
Private Sub DeleteItems(ByRef Folder As Object)
Dim Item As Object
#Else
Private Sub DeleteItems(ByRef Folder As Outlook.MAPIFolder)
Dim Item As Outlook.MailItem
#End If
For Each Item In Folder.Items
If Item.Categories = "Needs Distribution" Then
Item.Delete
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 the items in the SourceFolder to the DestinationFolder if the item in the SourceFolder
'do have the category "Needs Distribtion". The items are change to unread
#If LateBinding Then
Private Sub CopyMarkedItems(ByRef SourceFolder As Object, ByRef DestinationFolder As Object)
Dim Item As Object
Dim Copy As Object
#Else
Private Sub CopyMarkedItems(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 Item.Categories = "Needs Distribution" Then
Set Copy = Item.Copy
Copy.Move DestinationFolder
If Copy.UnRead = False Then
Copy.UnRead = True
End If
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
Dim TotalMessagesInInbox As Long
Set OutLookApp = CreateObject("Outlook.Application")
Set NS = OutLookApp.GetNamespace("MAPI")
'this ensures the name space has the category "Needs Distribution"
If Not CategoryExists(NS, "Needs Distribution") Then
'see https://msdn.microsoft.com/en-us/library/office/ff860420.aspx for possible colors
NS.Categories.Add "Needs Distribution", olCategoryColorTeal
End If
'add source folder here
Set SourceFolder = NS.Folders("Personal Folders").Folders("Inbox")
'assigns the category "Needs Distribution" to the items in the Source folder
'if and of the keywords are found in the subject
'any number of keywords can be added to this procedure call
MarkForDistribution SourceFolder, "Deemed"
'add destination folders here
Set DestFolder = NS.Folders("Personal Folders").Folders("paul")
CopyMarkedItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("james")
CopyMarkedItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("john")
CopyMarkedItems SourceFolder, DestFolder
'delete the distributed items in the SourceFolder
DeleteItems SourceFolder
TotalMessagesInInbox = SourceFolder.Items.Count ' counts total number of emails in inbox
MsgBox (TotalMessagesInInbox & " E-mails remain in the inbox, please check manually")
Set NS = Nothing
Set SourceFolder = Nothing
Set DestFolder = Nothing
End Sub