Outlook 2013 VBA Macro Not Running on New Messages

Question

I am having trouble getting a macro to run on newly received emails in Outlook 2013.

The macro below (which is merely edited from code I found to accomplish a similar goal) is designed to rename the attachment to whatever the subject of the email is and then save it into a given folder on the desktop.

I set the rule below to run this script on emails given certain parameters. The rule will ALWAYS move the matching emails to the folder that it should, however, it does not always apply the macro to it.

What I have found is that it will only apply the macro on previously received email AND only if the message is selected in the list of emails in that folder.

For example, if the folder is empty and I receive an email (we will call it "email A") that matches the criteria, it just gets moved to the correct folder and marked read and no macro is run.

But, if I select "email A" so that it shows in the reading pane and another matching email comes in ("email B"), it will run the macro on "email A" only and not "email B."

I am pretty new to this, but seems like I'm just overlooking something. Any and all help would be greatly appreciated.

Rule:

Apply this rule after a message arrives
from '[email protected]'
and which has an attachment
and on this computer only
move it to the 'XYZ' folder
and run Project1.ThisOutlookSession.SaveAttachments
and mark it as read

Code:

Sub SaveAttachments(itm As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String

' Get the path to your My Documents folder
' strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "Z:\Desktop\GAreports\"
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFileName = objSubject & ".csv"
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFileName
Debug.Print strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Tim Williams Tim Williams · Accepted Answer · 2015-02-23T20:55:49

See here for info on running a macro from a rule: http://qlockwork.com/timetrackingthoughts/2012/10/microsoft-outlook-2010-tips-how-to-run-a-vba-macro-on-new-emails/

From a quick glance your problem seems to be that you're ignoring the item which gets passed to your procedure:

Sub SaveAttachments(itm As Outlook.MailItem)

itm is the new mail item, but in your macro you're working with the selected item(s) in the Inbox: you should instead work directly with itm

You also don't need this:

Set objOL = CreateObject("Outlook.Application")

since there's already an Application object available to any VBA code running within Outlook

Outlook 2013 VBA Macro Not Running on New Messages

1 Answers