I have already given you the GetPath function that does that. Call it from your code. I have not included below the other functions, that appear elsewhere in the thread, and which are called by this macro. They go below this code. i.e. Option Explicit is the first line of the module.

I have annotated the code where it might be helpful.

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath() As String

    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
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)
    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

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    fPath1 = Replace(fPath1, "\", "")

    fPath2 = GetPath
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
        'so end processing
        GoTo lbl_Exit
    End If

    'fPath2 = Replace(fPath2, "\", "") 'superfluous as there is no backslash character in fpath2

    strPath = strRoot & fPath1 & "\" & fPath2
    'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    If olItem.sender Like "Nathan Davies" Then
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    'Remove illegal filename characters that might appear in the subject
    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, strPath, fname
    'The CopyToExcel function earlier in the thread had only one named parameter
    CopyToExcel olItem
    If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
        objItem.Delete
    End If
lbl_Exit:
    Exit Sub
End Sub