Consulting

Results 1 to 11 of 11

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

  1. #1

    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

  2. #2
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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

  4. #4
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    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

  6. #6
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    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!

  8. #8
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #9
    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
    CheersMacro2.jpg

  10. #10
    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.
    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.
    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.
    Rule.jpg
    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:

    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!
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •