?
Solved

Can You create Code to Save Word & Excel Documents to Sharepoint Sub folders?

Posted on 2010-08-24
43
Medium Priority
?
554 Views
Last Modified: 2012-05-10
I have Word & Excel docs that have to be saved to share point locations. Can you setup code to be applied to a new macro and setup a custom macro button and attach it to my menu in Word and click on it to automatically save that doc to my sharepoint location folders?
Word.jpg
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
  • 21
  • 19
  • 3
43 Comments
 
LVL 17

Expert Comment

by:calacuccia
ID: 33512806
Something like this: Assign this code to your button


Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)

With dlgSaveAs
.InitialFileName = "http://SERVERNAME/SHAREPOINT_SITE/"
.Show
.Execute
End with

Open in new window

0
 

Author Comment

by:matrix0511
ID: 33514468
calacuccia, that's ok. However, chris_bottomley: has created similar code for me with Outlook where I click on a button that has code he setup that will automatically save that email to a specific share point sub folder along with other bells and whistles.

So, I would like to see if I can have similar code setup with this Word or Excel doc.


0
 
LVL 17

Expert Comment

by:calacuccia
ID: 33520377
Hi

(For other readers in future)
The instruction for how to assign the macros can be found back here --> http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26425429.html

The macros I would suggest:

Word:

Sub SavetoMySharepoint()
ActiveDocument.SaveAs  "http://SERVERNAME/SHAREPOINT_SITE/" & ActiveDocument.Name
End Sub

Excel

Sub SaveXLtoMySP()
ActiveWorkbooks.SaveAs "http://SERVERNAME/SHAREPOINT_SITE/" & ActiveWorkbook.Name
End Sub



Excel:

0
Free learning courses: Active Directory Deep Dive

Get a firm grasp on your IT environment when you learn Active Directory best practices with Veeam! Watch all, or choose any amount, of this three-part webinar series to improve your skills. From the basics to virtualization and backup, we got you covered.

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33520713
I have taken the original code and modified it from outlook to suit both excel and word.  PAste the code into a normal module and then call Q_26425352 to implement the functionality.

calacuccia, FYI it bears no relation to your code since it analyses the file name for the project, creates sub directories if the required one cannot be found and additionally seperates data into folders according to the financial year.

As such it is the result of a fair bit of work on outlook as indicated by matrix0511 earlier.

Chris
Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
    If User = "CB" Then
        strRootFolder = "c:\deleteme\"
    Else
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
    End If
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set xltype = activedocument
End Function

Open in new window

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33520749
Sorry mucked up the folder defaults again!
Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set xltype = activedocument
End Function

Open in new window

0
 
LVL 17

Expert Comment

by:calacuccia
ID: 33520809
No problem Chris, I don't have long toes :-) And I figures it could be a little more complicated :-)
0
 

Author Comment

by:matrix0511
ID: 33522586
Chris when I clicked the button I setup to use the new code I get a compile error. See below.
8-25-2010-11-20-34-AM.jpg
8-25-2010-11-21-24-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33523631
Can't see how that happened ... unless you are using word and selected the wrong start point ... it should be Q_26425352.

If however that is what you did, can you tell me details about installed version and type of file you are running against.

Chris
0
 

Author Comment

by:matrix0511
ID: 33523793
when you say wrong start point...you mean when I pasted?

I think I did it right.

I'm using an older version of MS Word. 2003. Could that be the culprit??

We could always run in debug mode to troubleshoot right?
8-25-2010-1-06-56-PM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33525281
I mean what sub have you linked your button to?
0
 

Author Comment

by:matrix0511
ID: 33525427
See screen prints.

This is the code I copied and pasted.

Then with the customize box up I simply dragged and dropped it at the menu bar shown.


Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
   
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
       
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set xltype = ActiveDocument
End Function

8-25-2010-3-48-54-PM.jpg
8-25-2010-3-49-07-PM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33525788
Small mistake ... didn't test in word ... I was soooooooooo (over) overconfident!
Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set wdtype = activedocument
End Function

Open in new window

0
 

Author Comment

by:matrix0511
ID: 33532382
Ok, if the word doc has a project number in the Word file name like below.I click on the button and it saves the word doc to sharepoint like it's supposed to.

However, if I have a word doc that does NOT have a project number in the path (as some may have), when i click the button it prompts me to enter a project number which is fine. I enter an "existing" project number (in this case CTH1100067) but when I click ok it gives error.

What I would ilke for it to do is go out and see the existing folder and allow me to save that doc to it OR if it doesn't see project folder create a new folder.

It does this with the other code for Outlook. So I'm sure we can get it to work for word.

Thanks!
8-26-2010-10-44-17-AM.jpg
8-26-2010-10-44-50-AM.jpg
8-26-2010-10-50-36-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33533900
Missed one of the parameter edits ... confirmed that particular issue is no more so see again how it looks.

Chris
Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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(.Name)
                ft = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set wdtype = activedocument
End Function

Open in new window

0
 

Author Comment

by:matrix0511
ID: 33534665
Ok. Almost home. One last thing on this one. It is working now. However, when I enter the project name It would be nice if I could put in the project name AND the description all in that same box and have it create the folder with the description in it so I wouldn't have to keep going back to rename it and add the description afterwards.

And I seem to recall that when you were doing the code for Outlook I was able to test it creating the new project sub folder WITH the desctiption as well.

Is that possible Chris? It would really be nice to have. Thanks!
8-26-2010-1-58-39-PM.jpg
8-26-2010-2-01-00-PM.jpg
0
 

Author Comment

by:matrix0511
ID: 33534813
Chris, I have created one last question for you regarding all this Word/Outlook modifications.

See question details below.


Title: Can I have code to Automate Outlook Replies?


ID: 26432334 | Points: 500


http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_26432334.html
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33534874
Its the same code in that respect so I would expect it to behave the same in both cases.

A quick look over tells me it wouldn't work that way ... or certainly not in the excel/word variant anyway.  There is no reason to think it can't be done but it looks like a tidy chunk of work to fit it into the existing structure.

Chris
0
 

Author Comment

by:matrix0511
ID: 33535452
Ok. It just seemed like it wouldn't require as much effort to allow for the description.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33535555
The effort is in getting into the strings that are mixed to produce the output but the structure has developed so it's not immediately obvious which ones and for me will require a fair bit of testing to try and get the paths right(ish).

Each of the changes has had such isssues, i.e. the last edit that I needed was after a few days of work trying to work a structure into the existing code - and I still missed a line.

Chris
0
 

Author Comment

by:matrix0511
ID: 33535631
Ok. Will you at least be able to work on the new question I setup for you?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33536298
Indeed I will.  I'll be looking at it to try and scope it out hopefully sometime tomorrow.

Chris
0
 

Author Comment

by:matrix0511
ID: 33536347
Ok. Thanks Chris! I really appreciate it!!!
0
 

Author Comment

by:matrix0511
ID: 33577218
Hey Chris, in regards to this code you created for me to auto save my Word & Excel to sharepoint, all my Word docs work great when I used the code.

However, when I add the custom button in Excel and click it it keeps prompting me for project number even when i have excel spreadsheets with the CTH number in the file name. and even when I put in a project number it then gives error.

I have provided the code that works fine in Word but does not for Excel.



Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
   
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
       
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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(.Name)
                ft = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set wdtype = ActiveDocument
End Function

9-1-2010-10-12-25-AM.jpg
9-1-2010-10-12-59-AM.jpg
0
 

Author Comment

by:matrix0511
ID: 33645727
Chris, this is the only other remaining open question that still needs to be completed. could you help me with this one? It's not about Outlook. Just Excel. and it is probably an easy fix for you.

Thanks!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33645760
I didn't realise there was one still open.  Can you refresh me on where it is?

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646072
By which I mean what is the requirement at this point.

Chris
0
 

Author Comment

by:matrix0511
ID: 33646168
Ok. See screen prints below. for some reason, when i run the macro for the code you setup instead of it recognizing the existing project number (CTH1100070), and saving to sharepoint. it immediately just pops up a box for the project number like it doesn't see the project number.

Also, for some reason I am not able to creat a custom button like I am able to in Word. It's just a little differnt in Excel when doing macros.
9-10-2010-9-23-05-AM.jpg
9-10-2010-9-23-30-AM.jpg
9-10-2010-9-27-32-AM.jpg
9-10-2010-9-27-40-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646186
JUst given myself a quick refresh.  I have tested with excel and it saves fine to the sharepoint folder.

Can you confirm the filename(s) involved?  Also what happens if you step through and after the call to doctype?

Chris
0
 

Author Comment

by:matrix0511
ID: 33646189
I just want to be able to click the button to save Excel doc to sharepoint autmatically like it has been doing for Word.

here is the current code that is setup in Excel that you did for me:



Option Explicit

Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
   
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
       
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set xltype = activedocument
End Function
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646238
Been a while since 2003, but the macro is in personal.xls.  I presume you can check for personal.xls when looking for the macro to assign.

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646252
Also can you confirm where the code was placed in word?

Chris
0
 

Author Comment

by:matrix0511
ID: 33646422
Chris, I stepped through each line of code using F8 and when it get's to the highlighted code below, right after I hit F8 again, it bring up that popup box for project number.

the file name is: CTH1100070 Test Case Matrix.xls
9-10-2010-9-54-20-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646505
If you hover .name what do you see?

Chris
0
 

Author Comment

by:matrix0511
ID: 33646605
".name"? I don't see .name
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646644
LOok higher up:

        If fnValProject(.Name) Then

Chris
0
 

Author Comment

by:matrix0511
ID: 33646649
0
 

Author Comment

by:matrix0511
ID: 33646674
Ok. I found that line, but when I hover over the .name or any word in that line it doesn't show anything like it does when I hover over the "fn".


9-10-2010-10-23-11-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33646850
OK - sorry it's a function of making it work (hah!) with excel and word.  I have modified below to pop up a message so what does it say?

Chris
Option Explicit

Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        MsgBox .Name
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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 = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = ThisWorkbook
End Function

Function wdtype() As Object
    Set xltype = activedocument
End Function

Open in new window

0
 

Author Comment

by:matrix0511
ID: 33647061
See below. when I opened the doc again and ran the macro, this time it gives me the  message below. I click OK, then it gives me that project popup box again.
9-10-2010-11-00-32-AM.jpg
9-10-2010-11-00-42-AM.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33647196
I was half expecting that let me consider how to get around it.

Chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 2000 total points
ID: 33647225
Easy enough ...

He sez!

Chris
Option Explicit

Sub Q_26425352()
Dim intIncrement As Integer
Dim fn As String
Dim ft As String
Dim fso As Object
Dim strDOSFolder As String
Dim strRootFolder As String
Dim strFYAffix As String
    
        strRootFolder = "\\cth-ws01\corp\IT\Shared Documents\Project Documents\"
        strRootFolder = "t:\"
        
    Set fso = CreateObject("scripting.filesystemobject")
    With docType
        If fnValProject(.Name) Then
            ' If NOT the current fiscal year
            If 2000 + Mid(fnGetProject(.Name), 4, 2) <> GetFiscalYr Then
                strRootFolder = strRootFolder & "20" & Mid(fnGetProject(.Name), 4, 2) & "\"
            End If
            strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(.Name))
            If strDOSFolder = "" Then
                strDOSFolder = findFuzzyFolder(strRootFolder, FileNameCharsOnly(fnGetProject(.Name)))
                If strDOSFolder = "" Then
                    md strRootFolder & fnGetProject(.Name), True
                    strDOSFolder = fnGetProject(.Name)
                End If
            End If
            fn = strRootFolder & strDOSFolder & "\" & FileNameCharsOnly(.Name)
            ft = "." & fso.getextensionname(.Name)
            fn = Left(fn, Len(fn) - Len(ft))
            intIncrement = 1
            Do While fso.FileExists(fn & "_" & intIncrement & ft)
                intIncrement = intIncrement + 1
            Loop
            .SaveAs fn & "_" & intIncrement & ft
        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)
                    strDOSFolder = strRootFolder & fn
                    md strDOSFolder, True
                    If strDOSFolder = "" Then Exit Sub
                End If
                fn = strDOSFolder & "\" & FileNameCharsOnly(.Name)
                ft = "." & fso.getextensionname(.Name)
                intIncrement = 1
                Do While fso.FileExists(fn & "_" & intIncrement & ft)
                    intIncrement = intIncrement + 1
                Loop
                .SaveAs fn & "_" & intIncrement & ft
            End If
        End If
    End With

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

Function GetFiscalYr(Optional dt As Variant)
    If IsMissing(dt) Then dt = Now()
    GetFiscalYr = Year(dt) + Abs(dt >= DateSerial(Year(dt), 4, 1))
End Function


Function docType() As Object
    If Application.Name = "Microsoft Excel" Then
        Set docType = xltype
    ElseIf Application.Name = "Microsoft Word" Then
        Set docType = wdtype
    End If
End Function

Function xltype() As Object
    Set xltype = activeworkbook
End Function

Function wdtype() As Object
    Set wdtype = activedocument
End Function

Open in new window

0
 

Author Comment

by:matrix0511
ID: 33648649
Hey Chris, that worked this time.

Listen, thanks so very much for all your help!!

May I ask if I can look you up down the road if I need similiar code work done? Your the best I have ever seen!

Have a great weekend buddy!!
0
 

Author Closing Comment

by:matrix0511
ID: 33648654
The best code work I have ever seen! 100% satisfied.
0

Featured Post

Free Backup Tool for VMware and Hyper-V

Restore full virtual machine or individual guest files from 19 common file systems directly from the backup file. Schedule VM backups with PowerShell scripts. Set desired time, lean back and let the script to notify you via email upon completion.  

Question has a verified solution.

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

This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
This article describes a serious pitfall that can happen when deleting shapes using VBA.
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…
If you’ve ever visited a web page and noticed a cool font that you really liked the look of, but couldn’t figure out which font it was so that you could use it for your own work, then this video is for you! In this Micro Tutorial, you'll learn yo…

650 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