Outlook Macro Attachment Saving

[Tmiller94]

I am not very savvy with the coding. I found one and lightly modified it to save attachments using the subject name for me. I need assistance on getting it to save the attachments as only part of the subject name.
Subject name, "[EXTERNAL] APLORD:214 File for admission 0220X0119AO002198"
Needed attachment just saved as, "0220X0119AO002198"

If you are able to help, i would GREATLY appreciate it as i have to sort through hundreds of these emails daily.

Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim strSubject As String, strExt As String
Dim objAtt As Outlook.Attachment
Dim saveFolder As String


Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Documents\Attachments"


Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection


For Each itm In Selection
For Each objAtt In itm.Attachments
' get the last 4 characters for the file extension
strExt = Right(objAtt.DisplayName, 4)
' clean the subject
strSubject = itm.Subject
ReplaceCharsForFileName strSubject, "-"


' put the name and extension together
file = saveFolder & strSubject & strExt

objAtt.SaveAsFile file
Next
Next

Set objAtt = 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

 

[John_w]

Change:

[COLOR=#333333]strSubject = itm.Subject[/COLOR]

to:

strSubject = Mid(InStrRev(itm.Subject, " ") + 1, itm.Subject)

 

[Tmiller94]

Thank you. It is now saying
"Run-time error '13':
Type mismatch"
When I go to the debug it highlights the line you gave me.

 

[John_w]

Sorry, the Mid arguments are in the wrong order! Try this:

    strSubject = Mid(itm.Subject, InStrRev(itm.Subject, " ") + 1)

 

[Tmiller94]

Thank you very much!! Worked perfect!
Just to be greedy, I do have email subject that i get once in a while that state,

"[EXTERNAL] APLDFW:214 proforma for admission 039010019AD000342, status:214 Authorised" "[EXTERNAL] APLDFW:214 proforma for admission 039010019AD000340, status:Approved" and "[EXTERNAL] APLDFW:214 proforma for admission 039010019AD000336, status:Open"

Is there a way to incorporate that to just save as the number, removing the "status:214..."

 

[John_w]

Assuming the required string of numbers and letters occurs at the end of the subject or is followed by a comma, here's one way to handle both cases:

    Dim p1 As Long, p2 As Long
    p2 = InStrRev(itm.Subject, ",")
    If p2 = 0 Then p2 = Len(itm.Subject) + 1
    p1 = InStrRev(itm.Subject, " ", p2 - 1)
    strSubject = Mid(itm.Subject, p1 + 1, p2 - p1 - 1)