move outlook items to new folder, based on subject line

[Andrewajp002]

Hi All

Im trying to create a VB macro to move emails from one folder to another based on a set of criteria in the subject line (current code at bottom)

Folders
Source - Outlook.Session.Folders("Mailbox - Change Management").Folders("inboxtest").Items
Destination
Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("test")

Criteria
1) The subject field has the word "RFC" anywhere within it
2) A variable is created once confirmed that 1 exists containing the final 5 chars of the subject line

Reason for this, the last 5 chars will "always" be the ref number, using this variable I need the destination folder to be checked to see if a sub folder exists with that ref number, if not a new folder is created and the item moved in to that folder. If the folder does exist then the item is just moved and no duplicate folder is created.

If the outlook item doesnt have the word "rfc" in the subject line the item is to be ignored and move on to the next. (Hope thats clear enough )

The code below sort of works, but isnt very user friendly

Code so far

Option Explicit

Sub ParseRFC2()
Dim rfc As String
Dim RFCfolder As MAPIFolder
Dim Sel, item
Dim intPos As Long
Dim ItemsCount As Integer

' *1* Source: Default to complete folder, if nothing is selected
Set Sel = Outlook.Session.Folders("Mailbox - Change Management").Folders("inboxtest").Items
' *2* Remove or comment out the following three lines,
' if you do not want to have selected items processed
ItemsCount = Outlook.ActiveExplorer.Selection.Count
MsgBox (ItemsCount)
If Outlook.ActiveExplorer.Selection.Count > 0 Then
Set Sel = Outlook.ActiveExplorer.Selection
End If

' *3* Target folder
Set RFCfolder = Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("test")

For Each item In Sel
intPos = InStr(1, item.Subject, "RFC", vbTextCompare)
'intPos = InStr(Len(item.Subject) - 5, "RFC", vbTextCompare)
If intPos > 0 Then 'only Subjects with RFC in them
MsgBox ("> 0")
rfc = UCase(Mid(item.Subject, intPos, 5))
MsgBox (rfc)
On Error Resume Next
If RFCfolder.Folders(rfc) Is Nothing Then RFCfolder.Folders.Add rfc
On Error GoTo 0
item.Move RFCfolder.Folders(rfc)
End If
DoEvents
Next
End Sub

----------

Many Thanks

Andrew

[JP2112]

Welcome to the forum. Please use [vba][/vba] tags when posting code.

Is there something specific you need help with? You say the code works, so I'm not sure what needs to be done.

[Andrewajp002]

Hi, thanks for the welcome

Yeah, rookie mistake, The code doesnt work really, however I need a way to do what it is intended to, that is searching a source outlook folder, if the subject bode has a word in it, look to see if the relevant sub folder exists, if not create it, then move that email.

The code above seems to have many bugs

[JP2112]

OK. Is this something you want to happen automatically as emails are placed into the "source" folder?

[Andrewajp002]

sorry for the delay in this response, we have had a nice long 4 day weekend here in the UK

To answer your question, no, there is no action required, the emails, meeting requests etc just need to be moved to that folder.

Is it required for me to report the code with the VBA tags, I cannot see where to edit that post?

[BrianMH]

OK. Is this something you want to happen automatically as emails are placed into the "source" folder?

To answer your question, no, there is no action required, the emails, meeting requests etc just need to be moved to that folder.

This really doesn't clarify. Do you want to:
A) Run the code at a time to suit you which will move your emails, this requires user interaction.
B) When an email is received or put into the source folder for it to automatically be moved with no interaction from an end user.

[Andrewajp002]

This really doesn't clarify. Do you want to:
A) Run the code at a time to suit you which will move your emails, this requires user interaction.
B) When an email is received or put into the source folder for it to automatically be moved with no interaction from an end user.

Hi Brian

This will be run via manual interaction (A). The email will go in to the Inbox and the code when run will move the emails dependant on subject criteria to the destination folders.

Please advise if you require any further information.

Many Thanks

Andrew

[JP2112]

I think this will do what you want. This code will run automatically, whenever emails are added to the source folder. Once installed you would not call this code manually.

Kindly go through the code and make sure the path names are correct, I merely cut and pasted from your code.

[vba]Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.Folders("Mailbox - Change Management").Folders("inboxtest").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.mailItem
Dim endOfSubject As String
Dim destFolder As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
Set msg = item
' check if subject field contains "RFC"
If InStr(msg.Subject, "RFC") > 0 Then
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
' base folder
Set destFolder = Outlook.session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("test")
' if subfolder doesn't exist, create it
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
msg.Move destFolder.Folders(endOfSubject)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub[/vba]

After pasting this code into ThisOutlookSession, you must restart Outlook.

Whenever an item (an email) is added to the folder Mailbox - Change Management\inboxtest, it will be checked for "RFC" in the subject. If so, the last five characters are grabbed and a folder by that name is searched for in Mailbox - Change Management\RFC\Infra\test. If the folder does not exist, it is added. Finally, the item is moved into that folder.

I don't recommend moving items such as appointments, this can interfere with Outlook's automatic handling of appointment items.

[Andrewajp002]

Hi JP

Ive added the script to this outlook session and restarted, i doesnt move the current emails with RFC in the subject and if I move any new ones in to that folder I get a -2147352567 - Array index out of bounds see bottom code (partially solved)

If I move a meeting request it goes into the inboxtest folder ok without the error, but as stated will not be moved by the code.

Also, to clarify, Im working with outlook 2003, and the mailbox - change management is not my default mailbox, it is a shared mailbox however I have full permissions.

Many Thanks

Andrew

added note:

Ive added msgboxes to the code and it seems to fall over at the point of adding the new folders, if I add the sub folder in to the destination folder if the first email contains "RFC" it moves it successfully then stops. If the first email doesnt contain "RFC" it will not move on to the next, and if the folder doesnt exist it fails.

[vba] If InStr(msg.Subject, "RFC") > 0 Then
MsgBox (msg)
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
MsgBox (endOfSubject)
' base folder
Set destFolder = Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("test")
' if subfolder doesn't exist, create it
MsgBox (destFolder)
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
msg.Move destFolder.Folders(endOfSubject)
End If

[/vba]

[Andrewajp002]

Just to add, I now realise that it is set for one email at a time as it comes it, so there is no error in the fact that it stoped after the first one, if I moved another one it would do the same.

The issue now is that it doesnt move the email if there isnt a folder.

[Andrewajp002]

To try and clarify my jimberish, the code below works when a folder exists,
[vba]
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.Folders("Mailbox - Change Management").Folders("inboxtest").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim endOfSubject As String
Dim destFolder As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
Set msg = item
MsgBox (msg)
' check if subject field contains "RFC"
If InStr(msg.Subject, "RFC") > 0 Then
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
MsgBox (endOfSubject)
' base folder
Set destFolder = Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("test")
MsgBox (destFolder)
' if subfolder doesn't exist, create it
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
msg.Move destFolder.Folders(endOfSubject)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
[/vba]

However it brings up the "-2147352567 - Array index out of bounds " error message at the code below if the folder doesnt exist

[vba]

If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If

[/vba]

[JP2112]

I may have the syntax on that line wrong. It was air code, after all. You could try using OERN (On Error Resume Next) and blindly try to set a reference to the folder. If the reference = Nothing, create the folder. That is one way around the issue.

[Andrewajp002]

thanks jp

I'll give that a go tomorrow

[Andrewajp002]

ok, the OERN seems to have worked perfectly.

Now on to the next issue, if the word "RFC" exists is there a way to check if the last 5 chars are numeric eg 12345 and not partially or non numeric eg req"uests".

eg

[vba]

Dim endOfSubjectNumeric as Integer

If InStr(msg.Subject, "RFC") > 0 Then
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
'MsgBox (endOfSubject)
endOfSubjectNumberic = endOfSubject
If endOfSubjectNumeric <> Integer then
ProgramExit:
Else
' base folder
Set destFolder = Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("Requests")
'MsgBox (destFolder)
' if subfolder doesn't exist, create it
On Error Resume Next
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
msg.Move destFolder.Folders(endOfSubject)
End If
End If

[/vba]

[Andrewajp002]

during some testing on the main destination folder "Requests" sometimes when the email is moved it is duplicated, but not always, strange.

Also, the date on the moved email, eg outlook date changes to the current date, however the date in the email doesnt change from the original. Is there a way to set the date & time of the moved email to that of the actual email received date / time (eg as this is client side there may be emails sent to the mailbox out of work hours but not received by the outlook client in the office until the next working day.

Also, sorry for all these also's, can the check for "RFC also allow for variations, eg "RFc", "rfc" etc? if not no probs.

[vba]


Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.Folders("Mailbox - Change Management").Folders("inboxtest").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim endOfSubject As String
Dim destFolder As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
Set msg = item
'MsgBox (msg)
' check if subject field contains "RFC"
If InStr(msg.Subject, "RFC") > 0 Then
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
'MsgBox (endOfSubject)
' base folder
Set destFolder = Outlook.Session.Folders("Mailbox - Change Management").Folders("RFC").Folders("Infra").Folders("Requests")
'MsgBox (destFolder)
' if subfolder doesn't exist, create it
On Error Resume Next
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
msg.Move destFolder.Folders(endOfSubject)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub


[/vba]

Many Thanks

Andrew

[Andrewajp002]

with a small bit of assistance from another site I think I have it, mailbox is different as doing a live test on my own mailbox

[vba]
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.Folders("Mailbox - Parker, Andrew").Folders("inbox").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim endOfSubject As String
Dim destFolder As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
Set msg = item
'MsgBox (msg)
' check if subject field contains "RFC"
If InStr(msg.Subject, "RFC") > 0 Then
' get last five chars of subject line
endOfSubject = Right$(msg.Subject, 5)
If IsNumeric(endOfSubject) Then
'MsgBox (endOfSubject)
' base folder
On Error Resume Next
Set destFolder = Outlook.Session.Folders("Mailbox - Parker, Andrew").Folders("RFC").Folders("Infra").Folders("requests")
'MsgBox (destFolder)
' if subfolder doesn't exist, create it
'On Error Resume Next
If destFolder.Folders(endOfSubject) Is Nothing Then
destFolder.Folders.Add (endOfSubject)
End If
' move msg to subfolder
'On Error Resume Next
msg.Move destFolder.Folders(endOfSubject)
Else
'MsgBox ("not numeric")
End If
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub


[/vba]

[JP2112]

Congrats!

[Andrewajp002]

Morning JP or anyone else

When the email is moved it takes on the date / time of when it was moved not when it was received, can this date be set so it doesnt change when moved?

[Andrewajp002]

Also, is it easy to amend to allow for all items, not just email? Im not fussed about the calendar entries in this mailbox, they are being added to an external sharepoint calendar directly.