Based on your comments I think the following should work for you. It uses several of the functions I referred you to and includes a macro to test the main macro, which you can run as a script from a rule
Option Explicit
Sub TestMacro()
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
FileMessage olMsg
lbl_Exit:
Exit Sub
End Sub
Sub FileMessage(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
Dim strPath As String: strPath = "C:\Path\"
Dim strID As String
Dim lngID As Long
Dim lngPara As Long
Dim sBody As String
Dim vPara As Variant
'check if item is a mail item
If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
'Look for DCS in the subject
lngID = InStr(1, UCase(olItem.Subject), "DCS")
'If present grab the 7 characters starting with DCS
If lngID > 0 Then
strID = Mid(olItem.Subject, lngID, 7)
'ensure that the string is a valid ID
If Not IsNumeric(Right(strID, 4)) Then strID = ""
End If
'DCS string is not in the subject so look in the body
If strID = "" Then
sBody = olItem.Body
'split the body into paragraphs
vPara = Split(sBody, Chr(13))
For lngPara = 0 To UBound(vPara)
'check the paragraphs for the string DCS
' and if found validate it asa before
lngID = InStr(1, UCase(vPara(lngPara)), "DCS")
If lngID > 0 Then
strID = Mid(vPara(lngPara), lngID, 7)
If Not IsNumeric(Right(strID, 4)) Then strID = ""
End If
'ID is found so stop looking
If Not strID = "" Then Exit For
Next lngPara
End If
'ID is found so set the path to match
If Not strID = "" Then
strPath = strPath & UCase(strID) & Chr(92)
'create the folder path if it doesn't exist
CreateFolders strPath
'and save the message with a unique name
SaveUnique olItem, strPath, UCase(strID)
End If
lbl_Exit:
Exit Sub
End Sub
Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
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)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
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
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
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
Private Function FolderExists(fldr As String) As Boolean
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function