Saving Emails to Server Locations Macro on Receipt

[gmayor]

Using a message with your example subject, does the following get the path you want?

Sub Macro1()
    Dim olItem As MailItem
    Dim strPath As String
    Dim strProject As String, strDate As String
    Dim strSubject As String, strSender As String
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.currentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        strSubject = .Subject
        strDate = Format(.SentOn, "yyyymmdd")
        strSender = .sender
    End With
    strPath = GetPath(strSubject)
    If Not strPath = "" Then
        strProject = Mid(strSubject, Len(strPath) + 1)
        strProject = CleanFileName(strProject)
        strPath = "H:\400-499\" & strPath & "\" & strProject & "Correspondence by " & strDate & "_" & strSender
    End If
    MsgBox strPath
    lbl_Exit:
    Set olItem = Nothing
    Exit Sub
End Sub

Private Function GetPath(strSubject As String) As String
    Dim vNum As Variant
    vNum = Split(strSubject, Chr(32))
    strSubject = Replace(vNum(0), "-", "")
    If IsNumeric(strSubject) = True Then
        strSubject = CStr(vNum(0))
        GetPath = strSubject
    End If
End Function

Private Function CleanFileName(strFileName As String) As String
    Dim arrInvalid() As String
    Dim lng_Index As Long
    ' Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    ' Remove any illegal filename characters
    CleanFileName = strFileName
    For lng_Index = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
    Next lng_Index
    lbl_Exit:
    Exit Function
End Function