I don't know if it is my cognitive process or your explanations, but the more you explain the more confusing your requirement becomes.
I don't know if you want the project name that contains the five digit code e.g. 'P1234' or whether you want the full path. The following will provide both.
strPath is the path to the customer - "\\NEWBENSON\Projects\drawings\Customer" - No end slash
fPath1 is the path of the project - "\\NEWBENSON\Projects\drawings\Customer\P1234 Liverpool Street Station\"
strProject is the project - "P1234 Liverpool Street Station"
I still don't know where you want the Correspondence folders - in the customer folder or the project folder - and I don't know what you want for the Excel part you highlighted, but all the options you have raised are available by using the appropriate variables.
Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Private Function GetPath(strRootPath As String) 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(strRootPath)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
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 fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Dim vProject As Variant
Dim strProject 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")
If fPath1 = "" Then
MsgBox "User cancelled"
GoTo lbl_Exit
End If
strPath = strRoot & fPath1
Debug.Print strPath
CreateFolders strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
fPath2 = GetPath(strRoot & fPath1)
If fPath2 = "" Then
MsgBox "The ID entered does not exist"
GoTo lbl_Exit
End If
Debug.Print fPath2
vProject = Split(fPath2, Chr(92))
strProject = vProject(UBound(vProject) - 1)
Debug.Print strProject
'End 'Remove this line after testing the paths
If olItem.sender Like "*@dbensoncontrols.co.uk" Then 'Looks for messages from you
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
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
'CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
Exit Sub
End Sub