How can I automate sorting messages in Outlook by number and saving them to the associated file folder in a parent folder?

ktavui
ktavui used Ask the Experts™
on
Below are the actual parent folders and an example.

File "011 Residental" gets sent to> P:\0001-1000 >gets sent to folder  "11.0 drawings"


P:\0001-1000

P:\1301-1350

P:\1301-1350

P:\1351-1400

P:\1401-1450

P:\1451-1500

P:\1501-1550

P:\1551-1600

P:\1601-1650

P:\1651-1700

P:\1701-1750

P:\1751-1800

P:\1801-1850

P:\1851-1900

P:\1901-1950

P:\1951-2000

P:\2001-2050

P:\2051-2100

P:\2101-2150

P:\2151-2200

P:\2201-2250

P:\2251-2300

P:\2301-2350

P:\2351-2400

P:\2401-2450

P:\2451-2500

P:\2501-2550

P:\2551-2600
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
1001 = 1350 are invalid?
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
As suggested by my previous post there are blanks in teh folder list ... but you should be able to fill them out with reference to the supplied code.

BAsically by addition of a function to map the folders you should get the folder path without having to extend the original sub.

Note it could have been further simplified but I felt this approach was more maintainable for you so have implemented it as is

Chris
Sub FileByProject(Item As Outlook.MailItem)
    Dim objRegEx As Object, _
        colMatches As Object, _
        lngProject As Long, _
        strPath As String
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "project [0-9]{3,5}"
        .Global = True
    End With
    Set colMatches = objRegEx.Execute(Item.body)
    If colMatches.count > 0 Then
        lngProject = Replace(LCase(colMatches.Item(0)), "project ", "")
        If Len(lngProject) <= 4 Then
            strPath = strFolderpath(CStr(lngProject)) & Format(lngProject, "0000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        Else
            strPath = strFolderpath(CStr(lngProject)) & Format(lngProject, "00000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        End If
        If strPath <> "" Then
            Item.saveas strPath, olMsg
        End If
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Sub
 
Function strFolderpath(strProject As String) As String
' strProject is formed as:

    Select Case strProject
        Case Is < 1
            strFolderpath = ""
        Case Is <= 1000
            strFolderpath = "P\0001-1000\"
        Case Is < 1300
            strFolderpath = ""
        Case Is <= 1350
            strFolderpath = "P\1301-1350\"
        Case Is <= 1400
            strFolderpath = "P:\1351-1400\"
        Case Is <= 1450
            strFolderpath = "P\1401-1450\"
        Case Is <= 1500
            strFolderpath = "P\1451-1500\"
        Case Is <= 1550
            strFolderpath = "P\1501-1550\"
        Case Is <= 1600
            strFolderpath = "P\1551-1600\"
        Case Is <= 1650
            strFolderpath = "P\1601-1650\"
        Case Is <= 1700
            strFolderpath = "P\1651-1700\"
        Case Is <= 1750
            strFolderpath = "P\1701-1750\"
        Case Is <= 1800
            strFolderpath = "P\1751-1800\"
        Case Is <= 1850
            strFolderpath = "P\1801-1850\"
        Case Is <= 1900
            strFolderpath = "P\1851-1800\"
        Case Is <= 1950
            strFolderpath = "P\1901-1950\"
        Case Is <= 2000
            strFolderpath = "P\1951-2000\"
        Case Is <= 2050
            strFolderpath = "P\2001-2050\"
        Case Is <= 2100
            strFolderpath = "P\2051-2100\"
        Case Is <= 2150
            strFolderpath = "P\2100-2150\"
        Case Is <= 2200
            strFolderpath = "P\2151-2200\"
        Case Is <= 2250
            strFolderpath = "P\2200-2250\"
        Case Is <= 2300
            strFolderpath = "P\2250-2300\"
        Case Is <= 2350
            strFolderpath = "P\2300-2350\"
        Case Is <= 2400
            strFolderpath = "P\2351-2400\"
        Case Is <= 2450
            strFolderpath = "P\2400-2450\"
        Case Is <= 2500
            strFolderpath = "P\2451-2500\"
        Case Is <= 2550
            strFolderpath = "P\2500-2550\"
        Case Is <= 2600
            strFolderpath = "P\2550-2600\"
        Case Is <= 2650
            strFolderpath = "P\2200-2250\"
        Case Is <= 2600
            strFolderpath = "P\2250-2300\"
        Case Else
            strFolderpath = ""
    End Select

End Function

Open in new window

Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Forget to test for <1000 i.e. as 0006 ... this produced a quick correction.

CHris
Sub FileByProject(Item As Outlook.MailItem)
    Dim objRegEx As Object, _
        colMatches As Object, _
        lngProject As Long, _
        strPath As String
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "project [0-9]{3,5}"
        .Global = True
    End With
    Set colMatches = objRegEx.Execute(Item.body)
    If colMatches.count > 0 Then
        lngProject = Replace(LCase(colMatches.Item(0)), "project ", "")
        If Len(lngProject) <= 4 Then
            strPath = strFolderpath(lngProject) & Format(lngProject, "0000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        Else
            strPath = strFolderpath(lngProject) & Format(lngProject, "00000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        End If
        If strPath <> "" Then
            Item.saveas strPath, olMsg
        End If
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Sub
 
Function strFolderpath(strProject As Long) As String
' strProject is formed as:

    Select Case strProject
        Case Is < 1
            strFolderpath = ""
        Case Is <= 1000
            strFolderpath = "P\0001-1000\"
        Case Is < 1300
            strFolderpath = ""
        Case Is <= 1350
            strFolderpath = "P\1301-1350\"
        Case Is <= 1400
            strFolderpath = "P:\1351-1400\"
        Case Is <= 1450
            strFolderpath = "P\1401-1450\"
        Case Is <= 1500
            strFolderpath = "P\1451-1500\"
        Case Is <= 1550
            strFolderpath = "P\1501-1550\"
        Case Is <= 1600
            strFolderpath = "P\1551-1600\"
        Case Is <= 1650
            strFolderpath = "P\1601-1650\"
        Case Is <= 1700
            strFolderpath = "P\1651-1700\"
        Case Is <= 1750
            strFolderpath = "P\1701-1750\"
        Case Is <= 1800
            strFolderpath = "P\1751-1800\"
        Case Is <= 1850
            strFolderpath = "P\1801-1850\"
        Case Is <= 1900
            strFolderpath = "P\1851-1800\"
        Case Is <= 1950
            strFolderpath = "P\1901-1950\"
        Case Is <= 2000
            strFolderpath = "P\1951-2000\"
        Case Is <= 2050
            strFolderpath = "P\2001-2050\"
        Case Is <= 2100
            strFolderpath = "P\2051-2100\"
        Case Is <= 2150
            strFolderpath = "P\2100-2150\"
        Case Is <= 2200
            strFolderpath = "P\2151-2200\"
        Case Is <= 2250
            strFolderpath = "P\2200-2250\"
        Case Is <= 2300
            strFolderpath = "P\2250-2300\"
        Case Is <= 2350
            strFolderpath = "P\2300-2350\"
        Case Is <= 2400
            strFolderpath = "P\2351-2400\"
        Case Is <= 2450
            strFolderpath = "P\2400-2450\"
        Case Is <= 2500
            strFolderpath = "P\2451-2500\"
        Case Is <= 2550
            strFolderpath = "P\2500-2550\"
        Case Is <= 2600
            strFolderpath = "P\2550-2600\"
        Case Is <= 2650
            strFolderpath = "P\2200-2250\"
        Case Is <= 2600
            strFolderpath = "P\2250-2300\"
        Case Else
            strFolderpath = ""
    End Select

End Function

Open in new window

Should you be charging more for IT Services?

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Author

Commented:
"1001 = 1350 are invalid?" >> no, accidentally didn't add them


"As suggested by my previous post there are blanks in teh folder list ... but you should be able to fill them out with reference to the supplied code." >>sorry but I don't fully understand, could you explain further?
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
>>> As suggested by my previous post there are blanks in teh folder

i.e. 1000 to 1350 are missing but adding them is simply a clone of the other rows i.e.

Chris
Sub FileByProject(Item As Outlook.MailItem)
    Dim objRegEx As Object, _
        colMatches As Object, _
        lngProject As Long, _
        strPath As String
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "project [0-9]{3,5}"
        .Global = True
    End With
    Set colMatches = objRegEx.Execute(Item.body)
    If colMatches.count > 0 Then
        lngProject = Replace(LCase(colMatches.Item(0)), "project ", "")
        If Len(lngProject) <= 4 Then
            strPath = strFolderpath(lngProject) & Format(lngProject, "0000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        Else
            strPath = strFolderpath(lngProject) & Format(lngProject, "00000") & " the lofts (markups)" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        End If
        If strPath <> "" Then
            Item.saveas strPath, olMsg
        End If
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Sub
 
Function strFolderpath(strProject As Long) As String
' strProject is formed as:

    Select Case strProject
        Case Is < 1
            strFolderpath = ""
        Case Is <= 1000
            strFolderpath = "P\0001-1000\"
        Case Is <= 1050
            strFolderpath = "P\1001-1050\"
        Case Is <= 1100
            strFolderpath = "P:\1051-1100\"
        Case Is <= 1150
            strFolderpath = "P\1101-1150\"
        Case Is <= 1200
            strFolderpath = "P:\1151-1200\"
        Case Is <= 1250
            strFolderpath = "P\1201-1250\"
        Case Is <= 1300
            strFolderpath = "P:\1251-1300\"
        Case Is <= 1350
            strFolderpath = "P\1301-1350\"
        Case Is <= 1400
            strFolderpath = "P:\1351-1400\"
        Case Is <= 1450
            strFolderpath = "P\1401-1450\"
        Case Is <= 1500
            strFolderpath = "P\1451-1500\"
        Case Is <= 1550
            strFolderpath = "P\1501-1550\"
        Case Is <= 1600
            strFolderpath = "P\1551-1600\"
        Case Is <= 1650
            strFolderpath = "P\1601-1650\"
        Case Is <= 1700
            strFolderpath = "P\1651-1700\"
        Case Is <= 1750
            strFolderpath = "P\1701-1750\"
        Case Is <= 1800
            strFolderpath = "P\1751-1800\"
        Case Is <= 1850
            strFolderpath = "P\1801-1850\"
        Case Is <= 1900
            strFolderpath = "P\1851-1800\"
        Case Is <= 1950
            strFolderpath = "P\1901-1950\"
        Case Is <= 2000
            strFolderpath = "P\1951-2000\"
        Case Is <= 2050
            strFolderpath = "P\2001-2050\"
        Case Is <= 2100
            strFolderpath = "P\2051-2100\"
        Case Is <= 2150
            strFolderpath = "P\2100-2150\"
        Case Is <= 2200
            strFolderpath = "P\2151-2200\"
        Case Is <= 2250
            strFolderpath = "P\2200-2250\"
        Case Is <= 2300
            strFolderpath = "P\2250-2300\"
        Case Is <= 2350
            strFolderpath = "P\2300-2350\"
        Case Is <= 2400
            strFolderpath = "P\2351-2400\"
        Case Is <= 2450
            strFolderpath = "P\2400-2450\"
        Case Is <= 2500
            strFolderpath = "P\2451-2500\"
        Case Is <= 2550
            strFolderpath = "P\2500-2550\"
        Case Is <= 2600
            strFolderpath = "P\2550-2600\"
        Case Is <= 2650
            strFolderpath = "P\2200-2250\"
        Case Is <= 2600
            strFolderpath = "P\2250-2300\"
        Case Else
            strFolderpath = ""
    End Select

End Function 

Open in new window

Author

Commented:
Chris, I created a rule to run this script, and I've done several test runs. Is there anything that I might be missing?

Author

Commented:
Actually, I think I might be having trouble because the user that I am running the script as doesn't have privelages to write to the project folders, I will try as a different user.
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Note I made a small change to the original script from David so if that one worked then this one ought to ... of course I may have made a silly mistake but my functional test seemed ok.

Chris

Author

Commented:
This code is not working for me, is there anything that I might have to add?
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Was the original code from DAvid OK, and if so what project number are you 'suing' and i'll post the actual calculated path for the save and you can advise any error.

Chris

Author

Commented:
The original code actually doesn't appear to be working. I am using the code below.


Sub fileByProject(Item As Outlook.MailItem)
    Dim objRegEx As Object, _
        colMatches As Object, _
        lngProject As Long, _
        strPath As String
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "project [0-9]{3,5}"
        .Global = True
    End With
    Set colMatches = objRegEx.Execute(Item.Body)
    If colMatches.Count > 0 Then
        lngProject = Replace(LCase(colMatches.Item(0)), "project ", "")
        Select Case lngProject
            'Duplicate the following two lines once for each possible project'
            Case 1336
                strPath = "T:\1301-1350\1336 City and County - Bridge Rehabilitation at Various Locations, FY04 [test]" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        End Select
        If strPath <> "" Then
            Item.SaveAs strPath, olMSG
        End If
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Sub

Open in new window

Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
What are you doing to run the code?

Author

Commented:
I'm following these steps:

1.  Start Outlook
2.  Click Tools > Macro > Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects
4.  If not already expanded, expand Modules
5.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module.
6.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
7.  Edit the code as needed.  I included comments wherever something needs to or can change
8.  Click the diskette icon on the toolbar to save the changes
9.  Close the VB Editor
10. Create a rule that fires for these messages, or for all messages
11. Set the rule's action to "run a script" and select this script as the one to run


I'm using a rule to run it as a script on all messages in the Inbox,  i get this prompt (below) when the code runs, is the string "Remove illegal characters" supposed to be declared?


1.JPG
2.JPG
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Sorry I can't read a thing to see what is happening

Author

Commented:
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
I don't understand how it could have worked before but I have created something to do the function so if the function really doesn't exist then add it to the code module.

Chris
Function RemoveIllegalCharacters(str As String) As String
Dim regex As Object
Dim matches As Object
Dim arr() As String
Dim cnt As Integer
Dim dirColon As Boolean
    
    dirColon = Mid(str, 2, 1) = ":"
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^A-Za-z0-9$ %'\-_@~`\(\)\+\\,;=\[\]§-ÿ]"
    End With
    RemoveIllegalCharacters = regex.Replace(str, " ")
    regex.Pattern = " {2,}"
    RemoveIllegalCharacters = regex.Replace(RemoveIllegalCharacters, " ")
    'If dirColon Then RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, " ", ":", 1, 1)

End Function

Open in new window

Author

Commented:
Awesome ! it's working. BUT, it's only saving to the parent folder, do I have to add more code to direct it to the exact folder??
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Use the code from my http:#33951524 post, but do keep RemoveIllegalCharacters for example i.e replace fileByProject and leave anything else alone

Chris

Author

Commented:
below is the exact code as I entered it in the VBA module:

and this is how the files are saved into the parent folder:


Sub FileByProject(Item As Outlook.MailItem)
    Dim objRegEx As Object, _
        colMatches As Object, _
        lngProject As Long, _
        strPath As String
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Pattern = "project [0-9]{3,5}"
        .Global = True
    End With
     Set colMatches = objRegEx.Execute(Item.Body)
    If colMatches.Count > 0 Then
        lngProject = Replace(LCase(colMatches.Item(0)), "project ", "")
        If Len(lngProject) <= 4 Then
            strPath = strFolderpath(lngProject) & Format(lngProject, "0000") & " message" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        Else
            strPath = strFolderpath(lngProject) & Format(lngProject, "00000") & " message" & RemoveIllegalCharacters(Item.Subject) & ".msg"
        End If
        
    If strPath <> "" Then
            Item.SaveAs strPath, olMSG
        End If
    End If
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Sub
 
Function strFolderpath(strProject As Long) As String
' strProject is formed as:

    Select Case strProject
        Case Is < 1
            strFolderpath = ""
        Case Is <= 1000
            strFolderpath = "P:\0001-1000\"
        Case Is <= 1050
            strFolderpath = "P:\1001-1050\"
        Case Is <= 1100
            strFolderpath = "P:\1051-1100\"
        Case Is <= 1150
            strFolderpath = "P:\1101-1150\"
        Case Is <= 1200
            strFolderpath = "P:\1151-1200\"
        Case Is <= 1250
            strFolderpath = "P:\1201-1250\"
        Case Is <= 1300
            strFolderpath = "P:\1251-1300\"
        Case Is <= 1350
            strFolderpath = "T:\1301-1350\"
        Case Is <= 1400
            strFolderpath = "P:\1351-1400\"
        Case Is <= 1450
            strFolderpath = "P:\1401-1450\"
        Case Is <= 1500
            strFolderpath = "P:\1451-1500\"
        Case Is <= 1550
            strFolderpath = "P:\1501-1550\"
        Case Is <= 1600
            strFolderpath = "P:\1551-1600\"
        Case Is <= 1650
            strFolderpath = "P:\1601-1650\"
        Case Is <= 1700
            strFolderpath = "P:\1651-1700\"
        Case Is <= 1750
            strFolderpath = "P:\1701-1750\"
        Case Is <= 1800
            strFolderpath = "P:\1751-1800\"
        Case Is <= 1850
            strFolderpath = "P:\1801-1850\"
        Case Is <= 1900
            strFolderpath = "P:\1851-1800\"
        Case Is <= 1950
            strFolderpath = "P:\1901-1950\"
        Case Is <= 2000
            strFolderpath = "P:\1951-2000\"
        Case Is <= 2050
            strFolderpath = "P:\2001-2050\"
        Case Is <= 2100
            strFolderpath = "P:\2051-2100\"
        Case Is <= 2150
            strFolderpath = "P:\2100-2150\"
        Case Is <= 2200
            strFolderpath = "P:\2151-2200\"
        Case Is <= 2250
            strFolderpath = "P:\2200-2250\"
        Case Is <= 2300
            strFolderpath = "P:\2250-2300\"
        Case Is <= 2350
            strFolderpath = "P:\2300-2350\"
        Case Is <= 2400
            strFolderpath = "P:\2351-2400\"
        Case Is <= 2450
            strFolderpath = "P:\2400-2450\"
        Case Is <= 2500
            strFolderpath = "P:\2451-2500\"
        Case Is <= 2550
            strFolderpath = "P:\2500-2550\"
        Case Is <= 2600
            strFolderpath = "P:\2550-2600\"
        Case Is <= 2650
            strFolderpath = "P:\2200-2250\"
        Case Is <= 2600
            strFolderpath = "P:\2250-2300\"
        Case Else
            strFolderpath = ""
    End Select

End Function

Function RemoveIllegalCharacters(str As String) As String
Dim regex As Object
Dim matches As Object
Dim arr() As String
Dim cnt As Integer
Dim dirColon As Boolean
    
    dirColon = Mid(str, 2, 1) = ":"
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^A-Za-z0-9$ %'\-_@~`\(\)\+\\,;=\[\]§-ÿ]"
    End With
    RemoveIllegalCharacters = regex.Replace(str, " ")
    regex.Pattern = " {2,}"
    RemoveIllegalCharacters = regex.Replace(RemoveIllegalCharacters, " ")
    'If dirColon Then RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, " ", ":", 1, 1)

End Function

Open in new window

1.JPG
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
IN the code yu posted here 1340 and the others are all saved to T:\ rather than P:|

Chris

Author

Commented:
That was a test , I didn't  wanna make changes to the P:\ drive folders yet as there is valuable information...did that change deviate the code?
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
NO I simply noted the issue against the test data displayed in the graphic ... looking

Chris
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
At the moment as coded from the original question it looks for the project nnnn in th ebody of the email rather than the subject ... is that relevant against your test mails?

Chris

Author

Commented:
Yes, I tested with the project # in the body of the message.
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
I've just done a physical test and it works fine so in th ebody do you have 1340 or project 1340.

And if so delete over spaces and re-insert a single space then retry.

Chris

Author

Commented:
i have it as "project 1340", so it is saving to the specific folder within the parent folder?
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Not quite the baseline code saves it to the parent folder (with a prefix of the project) therefore so does the change asked for here (which was to remove the need to hard code the parent folder relationship to the project).

Chris
Software Quality Lead Engineer
Top Expert 2011
Commented:
Note if you want it saving as a sub folder of the parent, then that can be done but I suggest that in fairness that is a different question.

Chris

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial