Scan incoming mail and save attachments in all emails with specific subject lines

Hi all,
Every day I get an email with the same subject line ("today's update") with an attachment named mavrpt########### (the #'s are numbers).
Initially I tried to get VBA to scan and save all attachments containing "mavrpt" but this didn't work.

Is it possible to scan the incoming mail for a specific subject line, and then save the attachments to the same folder :C"userprofile"\Docs:etc
renaming the file to the subject line and the day's date. or even better, overwriting the previous saved in that folder?

All other solutions I have found seem to scan entire mailboxes and save all attachments that any email contains, I get alot of attachments and do not want all of them saved constantly.

Here's what I have currently (It is not elegant and does not work at all)

Thanks in advance


Public WithEvents olItems As Outlook.Items

Sub Application_Startup()
Set olItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Sub olItems_ItemAdd(ByVal Item As Object)
Dim NewMail As Outlook.MailItem
Dim Atts As Attachments
Dim Att As Attachment
Dim strPath As String
Dim strName As String

If Item.Class = olMail Then
Set NewMail = Item
End If

Set Atts = Item.Attachments

If Atts.Count > 0 Then
For Each Att In Atts
'chooses mavrpt files
If InStr(LCase(Att.FileName), "mavrpt""*") > 0 Then
'Use your wanted destination folder path to save the attachments
strPath = "C:\Users\**Chosen Path**"
strName = MailItem.Subject & ".xls"
Att.SaveAsFile strPath & strName
End If
Next
End If

End Sub

Rather than use the method you have attempted, use the following in an ordinary Outlook VBA module and create a rule to identify the incoming messages and use the 'SaveAttachments' main macro as a script associated with the rule to process the attachments as the messages arrive.

The attachments are saved by name in the attachments sub folder of your documents folder (which is created if not present). You can test the code by selecting a message with appropriate attachments and run the macro 'ProcessAttachment'.

I note that you want to save with the message subject. Before suggesting code to do that I would need to know what the message subject was likely to be, to avoid illegal filenames, and your comment 'overwriting the previous saved in that folder' needs clarification. The macro as shown will overwrite any file of the same name in the target folder.

Code:

---

Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Aug 2018
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strSaveFldr As String

    On Error GoTo lbl_Exit
    strPath = Environ("USERPROFILE") & "\Documents\Attachments\"
    CreateFolders strPath
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If olAttach.fileName Like "mavrpt*.*" Then
                strFname = olAttach.fileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
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

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

---

Thank you for this. So the subject line of the email reads
"Report for Worksheet: Name/Name."

Also I have a question about the:
If olAttach.fileName Like "mavrpt*.*"

for instance if the mavrpt file is called randomly "mavrpt12345678a12.345" will this code above still work?

Thank you for your help

You cannot have a forward slash "/" or a colon ":" in a filename and there may be illegal characters in the name itself, hence my reticence about naming files from subjects.
As for the attachment filenamed "mavrpt12345678a12.345" - then yes, and that's what the file will be saved as. Did you try it?
The ".345" extension is non-standard and not a type recognised by Windows.

sorry I meant to add .xls after the .345 "mavrpt12345678a12.345.xls"
so quickly running it, and sending myself the file, didn't seem to work,
The folder "Attachments was made, but the file was not saved into it"
I was considering using the code:

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)

To replace the "illegal" Characters in the subject line?

Again Thanks

Apologies, I modified an existing macro to enable it to do what you wanted, but named the path wrongly so the process would error out and quit. Use the following instead which corrects that error (and I have tested it) and also names the message as the (cleaned) subject.

Code:

---

Private Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Aug 2018
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strSaveFldr As String

    On Error GoTo lbl_Exit
    strSaveFldr = Environ("USERPROFILE") & "\Documents\Attachments\"
    CreateFolders strSaveFldr
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If olAttach.fileName Like "mavrpt*.*" Then
                strFname = CleanFileName(olItem.Subject) & ".xls"
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

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

---

For Some strange reason, these functions don't come up as a macro. As in I can't assign a macro and when I go to the macro part on Outlook, the functions don't appear. Have tried in both a "module 1" and "This outlook session"
Even when I hit "run" no macro comes up?

I think this code should work as there's no issue in debug. But as I said, the macro's don't seem to be an option, so I can't set a rule for incoming messages.

Cheers for the help!

The macros should be in Module1 and not in ThisOutlookSession.
Outlook can be fussy about security and you may need to self certify the project before the macros will run - see
http://www.gmayor.com/create_and_emp...gital_cert.htm
If the script option is not available when creating a rule, see https://www.slipstick.com/outlook/ru...-script-rules/ which explains how to activate it.

I have spent 3 days, trying to get this to work now.
However, the macros will still just not appear, even after having put digital signature and proofing it etc.

Any help would be great
CheersAttachment 22714

The macro will not appear in the macro list because it is not a stand alone macro. It requires a parameter - here olItem which refers to the message being processed.

Code:

---

Private Sub SaveAttachments(olItem As MailItem)

---

It also needs Private changing to Public (or removing altogether) as this was used when the macro was run from the ProcessAttachment macro i.e.

Code:

---

Sub SaveAttachments(olItem As MailItem)

---

As it is intended to be run from a Rule the Private part will make it invisible to the Scripts selector.
Attachment 22715
Had you copied all the code and jkust modified the main code your macros list should have displayed the ProcessAttachment macro, which can be run to test the code. The full code is as follows:

Code:

---

Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Aug 2018
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strSaveFldr As String

    On Error GoTo lbl_Exit
    strSaveFldr = Environ("USERPROFILE") & "\Documents\Attachments\"
    CreateFolders strSaveFldr
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If olAttach.fileName Like "mavrpt*.*" Then
                strFname = CleanFileName(olItem.Subject) & ".xls"
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

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

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
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

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

---

Don't forget to save the project when you quit Outlook!

Hi Graham Thanks for all your help!
Works an absolute charm, and the clean file name is far tidier than I ever had!
Cheers