Outlook - Save file from email with .xls attachment and from specific sender then move email to sub folder

Question

I want to trigger a macro when a new email from a specific email address with an .xls attachment is received in an inbox. I have tried to set a rule in outlook but it doesn't filter on the sender nor if it has an attachment.

What I would like to do is the following:

When a new email comes into the inbox check if it is from a certain email address ag:Myaddress.me.co.uk. If the email is not from the correct address do nothing.
If the subject line has certain words eg: " Price Checks". It the subject doesn't match do nothing.
If the email is from the correct address Check the new email has a .xls attachment. If it doesn't have the .xls attachment do nothing.
Save the attachment in a folder eg:"C:\MyFolder"
Mark the Email as Read and move to a sub folder eg: "PriceCheckFolder"

I have been using this code to check the inbox but it looks through all emails in the folder and I only want it to look at the first instance that fits the criteria.

Many Thanks Melinda

‘in thisworkbook

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim SubFolder As MAPIFolder

  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem

  If TypeName(item) = "MailItem" Then
    Set Msg = item
    Call SaveAttachmentsToFolder
  End If

ProgramExit:
  Exit Sub

ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub


Sub SaveAttachmentsToFolder()

'Error handling
  On Error GoTo SaveAttachmentsToFolder_err


‘in module1

' Declare variables
  Dim ns As NameSpace
  Dim Inbox As MAPIFolder
  Dim SubFolder As MAPIFolder
  Dim item As Object
  Dim Atmt As Attachment
  Dim FileName As String
  Dim i As Integer
  Dim varResponse As VbMsgBoxResult
  Dim StringLength As Long
  Dim Filename1 As String
  Dim FilenameA As String
  Dim FilenameB As String

'Set the variable values to be used in the code
  Set ns = GetNamespace("MAPI")
  Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  Set SubFolder = Inbox.Folders("Test")
  i = 0

' Check subfolder for messages and exit of none found
  If SubFolder.Items.Count = 0 Then
  ' "Nothing Found"
    Exit Sub
  End If

' Check each message for attachments
  For Each item In SubFolder.Items
    For Each Atmt In item.Attachments
      ' Check filename of each attachment and save if it has "xls" extension
      If Right(Atmt.FileName, 3) = "xls" Then
        StringLength = Len(Atmt.FileName)

        FileName = "\\feltfps0003\gengrpshare0011\Value Team\Melinda_BK\OutlookVBA\TestOutput\" & Left(Atmt.FileName, (StringLength - 13)) & Format(item.CreationTime, "ddmmmyyyy") & ".xls"
        Atmt.SaveAsFile FileName
        i = i + 1
      End If
    Next Atmt
  Next item

' Clear memory
SaveAttachmentsToFolder_exit:
  Set Atmt = Nothing
  Set item = Nothing
  Set ns = Nothing
  Exit Sub

' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"sub
Resume SaveAttachmentsToFolder_exit
End Sub

You are going to want to create a macro you run via a rule on each incoming message. You can pretty easily check the sender address and iterate through the attachments like you are doing. — enderland

enderland enderland · Accepted Answer · 2013-08-22T16:19:26

I have tried to set a rule in outlook but it doesn't filter on the sender nor if it has an attachment.

Create a rule calling the following script.

It will run on all incoming mail but only execute your code for whatever email address you look for

Sub checkEmailSenderAndDoStuff(myItem As MailItem)

    'set this up as a script to run on all incoming mail
    Dim myTargetEmailAddress As String
    myTargetEmailAddress = "[email protected]"

    'this will check if the sender email is whatever sender
    'you want to check from
    If myItem.SenderEmailAddress = myTargetEmailAddress Then
        'do whatever you wanted to do with attachments, moving, etc
    End If
End Sub

Outlook - Save file from email with .xls attachment and from specific sender then move email to sub folder

1 Answers