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