Graham, I have managed to change the code to save in the correspondence folder, its just the 5 character input i need to change.

Option ExplicitSub SaveMessage()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub
 
Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
    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 = InputBox("Enter the project name and number.", _
    "Save Message")
    fPath2 = Replace(fPath2, "\", "")
     
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "Correspondence" & "\Sent"
    CreateFolders strPath & "Correspondence" & "\Received"
     
    If olItem.Sender Like "*@email.co.uk" 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
    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
lbl_Exit:
    Exit Sub
End Sub
 
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
    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:
    Exit Function
End Function
Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
     
    Dim objFolder As Outlook.MAPIFolder
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String
     
     ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE"))
     'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error Resume Next
     ' Open the workbook to input the data
     ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("Sheet1")
     
    On Error Resume Next
     ' add the headers if not present
    If xlSheet.Range("A2") = "" Then
        xlSheet.Range("A2") = "Sender Name"
        xlSheet.Range("B2") = "Sent To"
        xlSheet.Range("C2") = "Subject"
        xlSheet.Range("D2") = "Body"
        xlSheet.Range("E2") = "Date"
    End If
     
     'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1
     
     'collect the fields
     
    strColA = olItem.SenderName
    strColB = olItem.To
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.ReceivedTime


             
     ' Get the Exchange address
     ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)
     
     
    If InStr(1, strColB, "/") > 0 Then
         ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = recip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        End Select
    End If
     ' End Exchange section
     
     
     'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
     
     'Next row
    rCount = rCount + 1
    xlWB.Save
          ' don't wrap lines
    xlSheet.Rows.WrapText = True
    xlWB.Save
    xlWB.Close 1
     
    If bXStarted Then
         'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub