Outlook macro to sort incoming emails based on attachment type

[Gus1987]

Hello,

Ive been trying to find a macro that will move emails with xls or xlsx attachments into a subfolder of the inbox called Spreadsheets.

I have multiple mailboxes and only want this to run on a single mailbox, so I believe using a rule to run a script on a specific inbox is the best way to go. Ive enabled the option but editing the registry so I can select the "run a script" rule, but the examples I have found online all give me various errors and im nowhere near experienced enough to resolve the issue.

This is the code I currently have, amended from an example I found online:

Sub MercedesExcel2(item As Outlook.MailItem)


 Dim olkAtt As Outlook.Attachment
    'Check each attachment
    For Each olkAtt In item.Attachments
        'If the attachment's file name ends with .xls or xlsx
        If Right(LCase(olkAtt.FileName), 5) = ".xlsx" Then
            'Move the message to Spreadsheets folder
            item.Move Session.GetDefaultFolder(olFolderInbox).Folders("Spreadsheets")
            
        ElseIf Right(LCase(olkAtt.FileName), 4) = ".xls" Then
        
            item.Move Session.GetDefaultFolder(olFolderInbox).Folders("Spreadsheets")
        
            Exit For
        End If
    Next
    Set olkAtt = Nothing






End Sub

When I receive an email with the specified attachments, I get an object cannot be found error and it highlights the line:

item.Move Session.GetDefaultFolder(olFolderInbox).Folders("Spreadsheets")

Im not sure what is wrong with it, as the folder does exist as a subfolder of the inbox.


Any help would be much appreciated.

Thanks

Steve

[gmayor]

Try the following, which has a little more error handling and which will create the folder if it is found to be missing.

Sub MercedesExcel2(item As Outlook.MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 27 Feb 2018 
Dim olkAtt As Outlook.Attachment
Dim strExt As String
Dim olFolder As Outlook.Folder
Dim bFound As Boolean
    For Each olFolder In Session.GetDefaultFolder(olFolderInbox).folders
        If LCase(olFolder.Name) = "spreadsheets" Then
            bFound = True
            Exit For
        End If
    Next olFolder
    If Not bFound Then
        Set olFolder = Session.GetDefaultFolder(olFolderInbox).folders.Add("Spreadsheets")
    End If

    'Check each attachment
    If item.Attachments.Count > 0 Then
        For Each olkAtt In item.Attachments
            strExt = Mid(olkAtt.fileName, InStrRev(olkAtt.fileName, Chr(46)))
            'If the attachment's file name ends with .xls or xlsx
            If LCase(strExt) = ".xls" Or LCase(strExt) = ".xlsx" Then
                item.Move olFolder
                Exit For
            End If
        Next olkAtt
    End If
lbl_Exit:
    Set olkAtt = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

[Gus1987]

Thank you Graham, this moves the emails however it seems to move them to a subfolder of a different mail account. The account I want to run this on is not the default account setup in outlook, so would I need to specify the account (store?) so it uses the Spreadsheets subfolder of the specific inbox?

[Gus1987]

I have this set up as a rule to run when an email arrives, but it creates a Spreadsheets subfolder on a different mail account in Outlook and moves the spreadsheets there.

How can I specify what mailbox the "spreadsheets" subfolder should be located in? The outlook application that will run this macro has dozens of outlook accounts and I cant let anything get mixed up.

[gmayor]

The following should hopefully address the sub folder of the Inbox into which the message arrives, based on the account. If not then without access to your system, which would not be practical, I regret I cannot help further.

Sub MercedesExcel2(item As Outlook.MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 27 Feb 2018
Dim olkAtt As Outlook.Attachment
Dim strExt As String
Dim olFolder As Outlook.Folder
Dim bFound As Boolean
Dim olRoot As Object
    
    Set olRoot = item.Parent
    For Each olFolder In olRoot.folders
        If LCase(olFolder.Name) = "spreadsheets" Then
            bFound = True
            Exit For
        End If
    Next olFolder
    If Not bFound Then
        Set olFolder = olRoot.folders.Add("Spreadsheets")
    End If

    'Check each attachment
    If item.Attachments.Count > 0 Then
        For Each olkAtt In item.Attachments
            strExt = Mid(olkAtt.fileName, InStrRev(olkAtt.fileName, Chr(46)))
            'If the attachment's file name ends with .xls or xlsx
            If LCase(strExt) = ".xls" Or LCase(strExt) = ".xlsx" Then
                item.Move olFolder
                Exit For
            End If
        Next olkAtt
    End If
lbl_Exit:
    Set olkAtt = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

[Gus1987]

Hi Graham, thanks again for your help but im getting the same issue, it seems to add the folder to a different mail account and moves the email there.

Im trying to learn at the same time, where it says:

Set olRoot = item.Parent

Is this telling the macro to only use the account that the email arrived in? Would it help if I specified the actual account (store?) so its forced to only check that account for the subfolder?

[Gus1987]

I think I have got it to work!

I noticed in your code that the only time the olFolder is set is if the folder is missing, so I guessed the issue was somewhere in the check to see if the folder existed. I removed this check as the folder will always exist on this mailbox.
I kept the olRoot and then defined olFolder as olroot.Folders("Spreadsheets") and that appears to have done the trick.

The full code I am using is now here:

Sub MercedesExcel4(item As Outlook.MailItem)


Dim olkAtt As Outlook.Attachment
Dim strExt As String
Dim olFolder As Outlook.Folder
Dim bFound As Boolean
Dim olRoot As Object
    
    Set olRoot = item.Parent
    Set olFolder = olRoot.Folders("Spreadsheets")


    'Check each attachment
    If item.Attachments.Count > 0 Then
        For Each olkAtt In item.Attachments
            strExt = Mid(olkAtt.FileName, InStrRev(olkAtt.FileName, Chr(46)))
            'If the attachment's file name ends with .xls or xlsx
            If LCase(strExt) = ".xls" Or LCase(strExt) = ".xlsx" Then
                item.Move olFolder
                Exit For
            End If
        Next olkAtt
    End If
lbl_Exit:
    Set olkAtt = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

I just want to thank you again Graham, I wouldnt have been able to get this to work without your help!

Im not sure what was wrong with my original code, my guess is that it was trying to check for the folder in the different mailbox which is why I was getting an object not found error?