Solved

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

Posted on 2010-08-24
43
536 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
  • 21
  • 19
  • 3
43 Comments
 
LVL 17

Expert Comment

by:calacuccia
Comment Utility
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
Comment Utility
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
Comment Utility
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
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
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
Comment Utility
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
Comment Utility
No problem Chris, I don't have long toes :-) And I figures it could be a little more complicated :-)
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
I mean what sub have you linked your button to?
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Indeed I will.  I'll be looking at it to try and scope it out hopefully sometime tomorrow.

Chris
0
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 

Author Comment

by:matrix0511
Comment Utility
Ok. Thanks Chris! I really appreciate it!!!
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
By which I mean what is the requirement at this point.

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Also can you confirm where the code was placed in word?

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
If you hover .name what do you see?

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
".name"? I don't see .name
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
LOok higher up:

        If fnValProject(.Name) Then

Chris
0
 

Author Comment

by:matrix0511
Comment Utility
0
 

Author Comment

by:matrix0511
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
I was half expecting that let me consider how to get around it.

Chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
The best code work I have ever seen! 100% satisfied.
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

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

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

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now