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
313 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 27
  • 23
50 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33478280
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33478310
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
ID: 33478636
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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:matrix0511
ID: 33478659
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
ID: 33478730
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
ID: 33478955
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
ID: 33479006
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
ID: 33479137
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
ID: 33479232
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
ID: 33479244
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
ID: 33479644
Yeah, it keeps falling for me.

Email subject line:

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

Author Comment

by:matrix0511
ID: 33479774
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
ID: 33479786
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
ID: 33482246
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
ID: 33482308
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
ID: 33482319
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
ID: 33483470
No. they are all emails
0
 

Author Comment

by:matrix0511
ID: 33483494
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
ID: 33483752
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
ID: 33484577
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
ID: 33484639
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
ID: 33484659
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
ID: 33485438

Won't be able to analyse till tomorrow
0
 

Author Comment

by:matrix0511
ID: 33485469
No problem.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33491585
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
 

Author Comment

by:matrix0511
ID: 33491820
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
ID: 33491829
Runtime error that pops up
runtime-error.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33491878
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
ID: 33491881
not sure what you mean by "data". what do you need? I thought I gave you the line code.
0
 

Author Comment

by:matrix0511
ID: 33491918
.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
ID: 33492295
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
ID: 33492333
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
ID: 33492346
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
ID: 33492362
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
ID: 33492401
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
ID: 33492537
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
ID: 33492551
yes
0
 

Author Comment

by:matrix0511
ID: 33492596
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
ID: 33492652
New Folder that was created.
new-folder.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33492698
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
ID: 33492923
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
ID: 33494274
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
ID: 33496886
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
ID: 33498282
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
ID: 33500576
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
ID: 33500855
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
ID: 33501034
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
ID: 33501334

Yep
0
 

Author Closing Comment

by:matrix0511
ID: 33501358
Outstanding Work!!!
0
 

Author Comment

by:matrix0511
ID: 33501448
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

NEW Veeam Agent for Microsoft Windows

Backup and recover physical and cloud-based servers and workstations, as well as endpoint devices that belong to remote users. Avoid downtime and data loss quickly and easily for Windows-based physical or public cloud-based workloads!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …
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…

728 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