• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 559
  • Last Modified:

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

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
matrix0511
Asked:
matrix0511
  • 21
  • 19
  • 3
1 Solution
 
calacucciaCommented:
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
 
matrix0511Author Commented:
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
 
calacucciaCommented:
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
 [eBook] Windows Nano Server

Download this FREE eBook and learn all you need to get started with Windows Nano Server, including deployment options, remote management
and troubleshooting tips and tricks

 
Chris BottomleyCommented:
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
 
Chris BottomleyCommented:
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
 
calacucciaCommented:
No problem Chris, I don't have long toes :-) And I figures it could be a little more complicated :-)
0
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
I mean what sub have you linked your button to?
0
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
Ok. It just seemed like it wouldn't require as much effort to allow for the description.
0
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
Ok. Will you at least be able to work on the new question I setup for you?
0
 
Chris BottomleyCommented:
Indeed I will.  I'll be looking at it to try and scope it out hopefully sometime tomorrow.

Chris
0
 
matrix0511Author Commented:
Ok. Thanks Chris! I really appreciate it!!!
0
 
matrix0511Author Commented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
I didn't realise there was one still open.  Can you refresh me on where it is?

Chris
0
 
Chris BottomleyCommented:
By which I mean what is the requirement at this point.

Chris
0
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
Chris BottomleyCommented:
Also can you confirm where the code was placed in word?

Chris
0
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
If you hover .name what do you see?

Chris
0
 
matrix0511Author Commented:
".name"? I don't see .name
0
 
Chris BottomleyCommented:
LOok higher up:

        If fnValProject(.Name) Then

Chris
0
 
matrix0511Author Commented:
0
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
Chris BottomleyCommented:
I was half expecting that let me consider how to get around it.

Chris
0
 
Chris BottomleyCommented:
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
 
matrix0511Author Commented:
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
 
matrix0511Author Commented:
The best code work I have ever seen! 100% satisfied.
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 21
  • 19
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now