Code Change To Add An Additional Sub Folder Path When Saving Email

[nathandavies]

Hi All,
I have this code which was developed by a user on here (G Mayor) and i now need to make a slight modification but i'm stuck as to how to make it.

The current code works like this: You input a company name, then you input the project number (5 digits) the code then looks through our server and saves the email in the correct folder location.

The New Code needs to work like this: You input a company name, then you input the project number (5 digits ie: A1234), then you input the sub project letter (1 letter ie: A) which is will create the sub folder from the project umber and the sub project letter (A1234-A). this will then create your folder path which will be like this (\\Server\Projects\drawings\Test\A1234 - Tran Station\A1234-A).

This is a copy of the current code. if anyone could help?

''Code complied by Graham Mayor!''

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\Drawings\"
 
Public Sub Save()
      'Last updated - 18 Aug 2017 - Gmayor
    Dim olObj As Object
    Dim olMsg As MailItem
    Dim selCount As Long
    Dim j As Long
    Dim fPath1 As String, fPath2 As String, fPath3 As String
    Dim strPath As String, strSavePath As String
     
    selCount = ActiveExplorer.Selection.Count
    If selCount = 0 Then GoTo lbl_Exit
     
    fPath1 = InputBox("Enter the customer folder name in which to save the messages." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = GetPath(fPath1)
     
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
         'so end processing
        GoTo lbl_Exit
    End If
     
    strPath = fPath2
     
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
    CreateFolders strPath & "\Documents" & "\Documents Received"
        CreateFolders strPath & "\Documents" & "\Documents Sent"
     
    For j = selCount To 1 Step -1
        Set olObj = ActiveExplorer.Selection.Item(j)
        If olObj.Class = olMail Then
                If InStr(1, olObj.Categories, "Processed") = 0 Then
            Set olMsg = olObj


            SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=True, bExcel:=False
                   olObj.Categories = "Processed" 'add this line
            olObj.Save 'add this line
        End If
    End If
    DoEvents 'add this line
Next j


lbl_Exit:
    Exit Sub
End Sub
 
Private Function GetPath(strCustomer As String) As String
      'Last updated - 18 Aug 2017 - Gmayor
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim bPath As Boolean
    Dim strPath As String
     
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function
 
Private Sub SaveItem(olItem As MailItem, strPath As String, bAttach As Boolean, bExcel As Boolean)
      'Last updated - 18 Aug 2017 - Gmayor
    Dim fname As String
    Dim strSavePath As String
     
    If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Sent\"
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Received\"
    End If
     
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strSavePath, fname
     
     If olItem.Sender Like "Nathan Davies" Then 'INSERT NAME HERE
        If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
        SaveAttachments olItem, strPath & "\Documents\Documents Sent\"
        End If
     Else
        SaveAttachments olItem, strPath & "\Documents\Documents Received\"
    
    'If bExcel = True Then
    'CopyToExcel olItem, strPath
    
       End If
lbl_Exit:
    Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
    strSaveFolder = strSaveFolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
    CreateFolders strSaveFolder
    For j = olItem.Attachments.Count To 1 Step -1
        Set olAttach = olItem.Attachments(j)
        If Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFolder, strFname, strExt)
                olAttach.SaveAsFile strSaveFolder & strFname
                 'olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.Save
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub
 
Private Function FileNameUnique(strPath As String, _
    strFileName As String, _
    strExtension As String) As String
     
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function
 
Private Sub CreateFolders(strPath As String)
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub
 
Private Function SaveUnique(oItem As Object, _
    strPath As String, _
    strFileName As String)
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
     'Debug.Print strPath & strFileName & ".msg"
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function
 
Private Function FileExists(filespec As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function
 
Private Function FolderExists(fldr As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function