Solved

Can you create code in Outlook to click a button to save email MSG to a network sub folder based on subject line?

Posted on 2010-08-19
50
306 Views
Last Modified: 2012-05-10
Need to have code setup to allow clicking a custom button in a new email window to save that email to a sharepoint sub folder that is created automatically if it does not already exist and will create the folder based on the project number defined in the subject line of the email.
0
Comment
Question by:matrix0511
  • 27
  • 23
50 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Can you say if the project number in the subject always takes the form:

CTHnnnnnnn

or is it Czznnnnnnn

or something else?

(z being alpha and n numeric)

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
OKay

It's getting rather difficult to test now due to the increased 'personalisation' so see how this goes.

It is a complete set of replacement functions for those currently in the module ... i.e. delete them all and replace with this code.

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bC[A-Z]{2}[0-9]{7}\b"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bC[A-Z]{2}[0-9]{7}\b"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
oK. Here is how the project numbering will work. In the project number it reveals the fiscal year.

so, on sharepoint there are project folders for fiscal year 2008, 2009, 2010 and 2011(current fiscal year).

So, since we are in fiscal year 2011 based on how my company works, that is why you see "CTH11000XXX".

The "CTH" will always be in the project number. But what will change each fiscal year are the first 2 digits. So next fiscal year it will go from "11" to "12". Then from there it will go to "13", "14", etc......


And there are times when I will get an email that has an older fiscall year project number in it.

For example, last week I got an email with the following subject line:

RE: CTH1000046 Test Case Matrix Form, CTH1000046_Application Detail Design Document_For User Approval

d
In that example the project number is for fiscal year 2010. Thus, the number is: CTH1000046. And I had to save that email to that older project folder and sub folder.

So at any given day I may get an email that references an older project number or current project number. But the one constant will be the first 3 characters...."CTH".

Does that make sense??
0
 

Author Comment

by:matrix0511
Comment Utility
Chris, before I add this code, let me know if you read my last comment and if this latest code will account for that.

Thanks.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
OKay locked onto CTH now

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
Chris, I get a runtime error after clicking the button. It took about 30 seconds while it looked like it was trying to process then it popped that error up below.
Runtime-Error.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Unfortunately no clues there I may have to work out a test so bear with me

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Just knocked up a quick test and it looks ok to me.  The precise code is as below just in case:

Can you advise the subject in the email you tested with?

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

                md "c:\deleteme\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Rats ... forgot to delete the test lines
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

'                md "c:\deleteme\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
Yeah, it keeps falling for me.

Email subject line:

RE: CTH1100044 - DV Package Request - Project CTH410214 (Cursor for Packagin)
0
 

Author Comment

by:matrix0511
Comment Utility
This is interesting. I went back and recopied the code again and ran the button. this is what I get when I click the button.
project-number.jpg
0
 

Author Comment

by:matrix0511
Comment Utility
That only happens with that particular email. When I try other emails I just get that runtime error above.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
I have tried the subject and that works fine for me, and as for the textbox that's the start of the functionality for when the project number is not found ... so when the project number is found the system falls over.

I just thought what Iomitted ... but it should still work after a fashion, i'll see what I can interpret from that thought!

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
APologies ... snap statement because that's not it - I implemented it fine just not in the way I first thought I would.

Still means the project is found ok when it errors up so what is the subject when it dsiplays teh textbox ... see if there's any clues there.

Chris!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Note the only differences between what I tested and your circumstances are the lines:

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True
'                md "c:\deleteme\" & fnGetProject(.Subject), True
                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)
'                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

and the mails themselves which leads me to ask, are all the mails mails or could they be invites or the like?

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
No. they are all emails
0
 

Author Comment

by:matrix0511
Comment Utility
do you think it would help to debug it like we did the code earlier? When I was hitting F8? don't remember how you did that, but it might help identify the culprit.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Absolutely it'll take longer to excute but will hopefuilly help.  Note as you step yoou can roll the cursor over variables to see their values which could also help

ONly one change but full code set for consistency.

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

stop

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

'                md "c:\deleteme\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}\b"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
Ok. I ran it again in debug mode as you provided.

Right after I hit F8 again after the highlighted code shown it pops up this project name box. however, the project number is clearly defined in the subject line of the email See screen print below.
Code.jpg
Code-2.jpg
0
 

Author Comment

by:matrix0511
Comment Utility
when I go ahead and enter the project number in the box manually and click ok. You can see a box pop u very briefly that shows it trying to copy the email to the sharepoint sub folder but then box immediately goes away and the run time error pops up.
0
 

Author Comment

by:matrix0511
Comment Utility
then as I keep hitting F8 past the first runtime error teh next runtime error comes when I get to this line of code:

.SaveAs fn & "_" & intIncrement & ft, olMSG

After hitting F8 it again tries to do a copy then gives that run time error below. I checked the sharepoint sub folders and nothing was uploaded.

NOt sure why it's not able to recognize the project number that is clearly defined  in the subject line.
second-error.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility

Won't be able to analyse till tomorrow
0
 

Author Comment

by:matrix0511
Comment Utility
No problem.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
First glance the project number didn't have a whitespace seperator it was a hyphen soo i'll fix that in the regex.

This time when it 'stops can you hover the cursor over each of the parameters fn, intincrement and ft and let me know what they are?

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

stop

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

'                md "c:\deleteme\" & fnGetProject(.Subject), True

                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:matrix0511
Comment Utility
Ok, I added the current code and clicked the button again to start the debug.

it gets to the highlighted code line below. Then when I click F8 one more time it sits there trying to process and I see a box pop up showing it trying to copy to the sharepoint sub folder then it goes away and the runtime error pops up.

so, right after it executes the code it fails:
.SaveAs fn & "_" & intIncrement & ft, olMSG
8-21-2010-11-22-18-AM.jpg
0
 

Author Comment

by:matrix0511
Comment Utility
Runtime error that pops up
runtime-error.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Yeah, we knew this already ... I need the data from the variables ... and perhaps your analysis to see why it isn't saving after all we only added the project to the mix.   And there is a bug in that at the moment to be fixed but first off get the mechanism working ish.

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
not sure what you mean by "data". what do you need? I thought I gave you the line code.
0
 

Author Comment

by:matrix0511
Comment Utility
.SaveAs fn & "_" & intIncrement & ft, olMSG

sorry, I think I know what your asking for now.

when i hover over "fn" from the code line above I see this pop up:

fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\CTH1100062\CTH11...

I wasn't able to see the full path it just stops at "CTH11..." which is kinda odd cause in that sub folder on sharepoint under that \CTH1100062 sub folder, i dont see any file or folder that starts with "CTH11...".

when I hover over "intIncrement" I see this pop up:

intIncrement = 1

when I hover over "ft" I see this pop up:

ft = ".msg"
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
I wonder if we're hitting the path limits!

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

    

    If Application.Inspectors.count = 0 Then Exit Sub

stop

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

'                md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject), True

                md "t:\" & fnGetProject(.Subject), True

'                md "c:\deleteme\" & fnGetProject(.Subject), True

'                fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                fn = "t:\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

'                fn = "c:\deleteme\" & fnGetProject(.Subject) & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Then

                    Exit Sub

                Else

'                    md "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn, True

'                    fn = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    md "t:\" & fn, True

                    fn = "t:\" & fn & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

 

Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = False

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnGetProject = regEx.Execute(strSubject)(0)

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
But chris, remember when you had the code saving the email just to the ROOT of the sharepoint location?

That was working great. I would think if there were path limit issues it would not have let us save to that root. Right?
0
 

Author Comment

by:matrix0511
Comment Utility
This is the function code from the previous quesiton that I added to the exisiting code that allowed me to save to the ROOT of sharepoint. it seems like it would not be much of an issue in terms of path limits to add one more folder. but  maybe it is.

below is the link to the previous question and thte function code you sent that worked then.

http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_26413323.html

Function FileNameCharsOnly(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
    FileNameCharsOnly = regEx.Replace(str, " ")
    regEx.Pattern = " {2,}"
    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")
    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)

End Function
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
As soon as the path becomes one character too many then it is an issue and just perhaps these messages do that now ... try the change and see ... it's not as if it will change anything overall.  BUt in the trying it ruiles in or out one one possibility.

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
When you get to the saveas command now, in the immediate window of the VBE (ctrl + G displays and is titled Immediate) type ?fn and enter ... post up the text it displays here norte text NOT graphic.

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
ok. I hit F8 until I got to the highlighted save as command in  yellow. I didn't hit F8 again. Instaed as you instructed I hit Ctrl + G and got the immediate box and typed:  ?fn and enter. This is the path that came up:


t:\CTH1100062\CTH1100062_Open WO Rpt_Package Build Request_PY

Do you want me to now continue to hit F8 to continue??
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
yes
0
 

Author Comment

by:matrix0511
Comment Utility
btw...that path that it posts in the code (t:\CTH1100062\CTH1100062_Open WO Rpt_Package Build Request_PY) is not a valid path.

The valid path it should be is:

T:\CTH1100062 - Modify Open WO to get grade from BOM

But after continiing to hit F8 it copied and did not error out this time. I went and checked the sharepoint location and opened the existing project sub folder(CTH1100062 - Modify Open WO to get grade from BOM)
but that saved message was not there.

But then I noticed what it did. the code created a new folder called: CTH1100062  and then copied the email message in that new folder. Unfortunately, we need for it to see the existing folder and copy the file there.

does that make sense? However, if that folder didn't already exist, like a new future folder, this process is what I would want it to do. create a new folder and copy the email file to it. it's just that ini this case, we already had a sub  folder there but for some reason it didn't copy to it.
0
 

Author Comment

by:matrix0511
Comment Utility
New Folder that was created.
new-folder.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Yeah, I mentioned earlier there was an issue with the folders which I need to fix ... the bottom line for now is to make sure we save without errors so can you test some for errors as earlier and if they seem to be resolved I can move onto the folder selection.

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
Ok Chris, I tested this about 10 times trying diffferent emails with different senarios. Some email with no project number in the subject line and it prompted me to enter project number and desciption which was great! that means i won't have to go back and rename it.

it all worked. in each test it would save to new folder. if i saved the same email twice it would save to existing folder. and make the file unique. Great!

so now we just need to get it to save to exisitng sub folder and we may be good!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Bit of a major fix!

See the code set replacement as below

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

Dim strDOSFolder As String

Dim strRootFolder As String

    

    strRootFolder = "c:\deleteme\"

'    strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"

'    strRootFolder = "t:\"

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.ConversationTopic))

                If strDOSFolder = "" Then

                    strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.ConversationTopic)))

                    If strDOSFolder = "" Then

                        md strRootFolder & fnGetProject(.ConversationTopic), True

                        strDOSFolder = fnGetProject(.ConversationTopic)

                    End If

                End If

                fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Or (Not fnValProject(fn)) Then

                    Exit Sub

                Else

                    strDOSFolder = findFuzzyFolder(strRootFolder, fn)

                    If strDOSFolder = "" Then

                        md strRootFolder & fnGetProject(fn), True

                        strDOSFolder = fnGetProject(fn)

                        If strDOSFolder = "" Then Exit Sub

                    End If

                    fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = True

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

Function findFuzzyFolder(dosPath As String, strFolder As String) As String

Dim fso As Object

Dim subFolder As Object



    strFolder = LCase(strFolder)

    findFuzzyFolder = ""

    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.folderexists(dosPath) Then

        For Each subFolder In fso.getfolder(dosPath).subfolders

            If Len(subFolder.Name) >= Len(strFolder) Then

                If Left(LCase(subFolder.Name), Len(strFolder)) = strFolder Then

                    findFuzzyFolder = subFolder.Name

                    Exit For

                End If

            End If

        Next

    End If

    

End Function



Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = True

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnGetProject = UCase(regEx.Execute(strSubject)(0))

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
Chris i added the code but when I click the button it doesn't seem to do anything. I checked the sharepoint location but nothing saves.
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
Comment Utility
APologies part of the ongoing issue with your pc / my pc!

If you check lines 10/11 they are both commented out ... though only 11 is required, and fixed below.

Chris
Sub Q_26408152()

Dim intIncrement As Integer

Dim fn As String

Dim ft As String

Dim fso As Object

Dim strDOSFolder As String

Dim strRootFolder As String

    

'    strRootFolder = "c:\deleteme\"

'    strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"

    strRootFolder = "t:\"

    If Application.Inspectors.count = 0 Then Exit Sub

    If Application.ActiveInspector.CurrentItem.Class = olMail Then

        'MsgBox "Code to follow!"

        Set fso = CreateObject("scripting.filesystemobject")

        With Application.ActiveInspector.CurrentItem

            If fnValProject(.Subject) Then

                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.ConversationTopic))

                If strDOSFolder = "" Then

                    strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.ConversationTopic)))

                    If strDOSFolder = "" Then

                        md strRootFolder & fnGetProject(.ConversationTopic), True

                        strDOSFolder = fnGetProject(.ConversationTopic)

                    End If

                End If

                fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.ConversationTopic)

                ft = ".msg"

                intIncrement = 1

                Do While fso.FileExists(fn & "_" & intIncrement & ft)

                    intIncrement = intIncrement + 1

                Loop

                .saveas fn & "_" & intIncrement & ft, olMsg

            Else

                fn = InputBox("Enter the project name or cancel to exit", "No Project Recorded - enter Project Number to continue")

                If fn = "" Or (Not fnValProject(fn)) Then

                    Exit Sub

                Else

                    strDOSFolder = findFuzzyFolder(strRootFolder, fn)

                    If strDOSFolder = "" Then

                        md strRootFolder & fnGetProject(fn), True

                        strDOSFolder = fnGetProject(fn)

                        If strDOSFolder = "" Then Exit Sub

                    End If

                    fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.ConversationTopic)

                    ft = ".msg"

                    intIncrement = 1

                    Do While fso.FileExists(fn & "_" & intIncrement & ft)

                        intIncrement = intIncrement + 1

                    Loop

                    .saveas fn & "_" & intIncrement & ft, olMsg

                End If

            End If

        End With

    End If

End Sub



Function fnValProject(strSubject As String) As Boolean

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = True

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnValProject = regEx.test(strSubject) = True

    

Set regEx = Nothing

End Function

Function findFuzzyFolder(dosPath As String, strFolder As String) As String

Dim fso As Object

Dim subFolder As Object



    strFolder = LCase(strFolder)

    findFuzzyFolder = ""

    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.folderexists(dosPath) Then

        For Each subFolder In fso.getfolder(dosPath).subfolders

            If Len(subFolder.Name) >= Len(strFolder) Then

                If Left(LCase(subFolder.Name), Len(strFolder)) = strFolder Then

                    findFuzzyFolder = subFolder.Name

                    Exit For

                End If

            End If

        Next

    End If

    

End Function



Function md(dosPath As String, Optional createFolders As Boolean)

Dim fso As Object

Dim fldrs() As String

Dim rootdir As String

Dim fldrIndex As Integer

    

    md = True

    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.folderexists(dosPath) Then

        fldrs = Split(dosPath, "\")

        rootdir = fldrs(0)

        If Not fso.folderexists(rootdir) Then

            md = False

            Exit Function

        End If



        For fldrIndex = 1 To UBound(fldrs)

            rootdir = rootdir & "\" & fldrs(fldrIndex)

            If Not fso.folderexists(rootdir) Then

                If createFolders Then

                    fso.createfolder rootdir

                Else

                    md = False

                End If

            End If

        Next

        Exit Function

    End If

End Function



Function fnGetProject(strSubject As String) As String

' Uses "Microsoft VBScript Regular Expressions" Type Library

Dim regEx As Object

    

    Set regEx = CreateObject("vbscript.regexp")

    regEx.IgnoreCase = True

    regEx.Pattern = "\bCTH[0-9]{7}"

    fnGetProject = UCase(regEx.Execute(strSubject)(0))

    

Set regEx = Nothing

End Function



Public Function olNav2Folder(foldername As String, Optional CheckOnly As Boolean) As Object

Dim olApp As Object

Dim olNs As Object

Dim olFldr As Object

Dim reqdFolder As Object

Dim arrFolders() As String

Dim nestCount As Integer

 

    On Error Resume Next

    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")

    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)

    arrFolders() = Split(foldername, "\")

    Set olApp = Outlook.Application

    Set olNs = olApp.GetNamespace("MAPI")

    Set reqdFolder = olNs.folders.item(arrFolders(0))

    For nestCount = 1 To UBound(arrFolders)

        If Not reqdFolder Is Nothing Then

            Set olFldr = reqdFolder.folders

            Set reqdFolder = olFldr.item(arrFolders(nestCount))

            If reqdFolder <> olFldr.item(arrFolders(nestCount)) Then

                If CheckOnly Then

                    Set reqdFolder = Nothing

                    Exit For

                Else

                    reqdFolder.folders.Add (arrFolders(nestCount))

                    Set olFldr = reqdFolder.folders

                    Set reqdFolder = olFldr.item(arrFolders(nestCount))

                End If

            End If

        Else

        End If

    Next

    Set olNav2Folder = reqdFolder

    Set olApp = Nothing

    Set olNs = Nothing

    Set olFldr = Nothing

    Set reqdFolder = Nothing

End Function



Function FileNameCharsOnly(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

    FileNameCharsOnly = regEx.Replace(str, " ")

    regEx.Pattern = " {2,}"

    FileNameCharsOnly = regEx.Replace(FileNameCharsOnly, " ")

    'If dirColon Then FileNameCharsOnly = Replace(FileNameCharsOnly, " ", ":", 1, 1)



End Function

Open in new window

0
 

Author Comment

by:matrix0511
Comment Utility
Chris, that worked. However, we actually have one more thing to address. I dont' know if you remember this dicsussion we had. But on the first question that was setup I talked about how these sharepoint folders are settup.

I mentioned that we have separate folders for each fiscal year. remember that? So on the sharepoint root location you will see a folder for 2008, 2009, & 2010. The current fiscal year we are using right now is 2011. But we don't create a folder for that one. We just keep all the folders in the root location.

Once fiscall year 2011 is done, I will create a folder called: 2011 and then move all the current 2011 folders into it. then for fiscall year 2012 I will have the folders in the same root location as they are now for 2011. and will continue on for 2013, 1014, etc. Does that make sense?

And that is what I had mentiond earlier. But not sure if you recall.

So, what that means is if I recieve any emails that reference an "older" fiscal year project number. Like the one I got a while back: "CTH1000024" (fiscal year 2010) or "CTH0900009" (fiscal year 2009) I would need to save that email to that corrisponding fiscal year folder.

I dont' get those older emails that often but I do get them.

I noticed this was still an outstanding issue because when was testing your latest code I pulled up an email that referenced an older fiscal year in the subject line. it was a 2010 project number. so when I clicked the button instead of saving to that 2010 folder on sharepoint, it saved it to the current root location. since it didn't see a folder called: CTH100024 it created it in that location.

How much effort will it be to add code to account for the older existing fiscal folders and also future, like when I finish with these current 2011 folders and then create a new 2011 folder and move onto 2012?

see below for how the older fiscal folders look like and what the project number scheme is inside each one.
2010-project-folder.jpg
project-subfolders-in-2010.jpg
2009-fiscal-year-folder.jpg
2009-project-sub-folders.jpg
2008-fiscal-year-folder.jpg
2008-project-sub-folders.jpg
high-level-overview-of-all-fisca.jpg
email-example-with-2010-project-.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
I'm sure it will be doable, the scope of edits to the spec I don't know just yet but although you did mention it earlier I would ask that you agree it as a new question that can be pursued initially to understand the scope of the change and then agree a way forward.

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
Ok. so just to confirm. do you want me to close out this current question now?

then create a new question to acount for the fiscal year folders??

0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility

Yep
0
 

Author Closing Comment

by:matrix0511
Comment Utility
Outstanding Work!!!
0
 

Author Comment

by:matrix0511
Comment Utility
Ok. I have closed this one out.

I have created a new question. Details below:

ID: 26422372

Can You create Code to Save Outlook Email Messages to Sharepoint Fiscal Year Sub-Folders?

Let me know if you need anything else from me.

Thanks!!
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

We are happy to announce a brand new addition to our line of acclaimed email signature management products – CodeTwo Email Signatures for Office 365.
Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now