Download e-mail attachments depending on subject line

[boyexcel]

Hi folks,

I'm quite a newbie when it comes to creating macros in Outlook and I've been researching on how to go about this as there's no recording app.

The issue that I'm having is that I am receiving several e-mails with the same subject line for the day but they contain different attachments.
For example:
Subject line: Daily activities: 03/26/2013
attached file: a.txt
Subject line: Daily activities: 03/26/2013
attached file: b.txt
Subject line: Daily activities: 03/26/2013
attached file: c.txt
Subject line: Daily activities: 03/26/2013
attached file: d.txt

I only download for example attachment a.txt and c.txt and start my work from there.

So my concern is, I would like to know how to create a macro to download specific attachments depending on the subject line and save it to a folder.

I can make use of a user prompt to enter the date to filter the subject lines containing the entered date and then automatically download the attachments that I needed to a folder.

Would this be possible?

Can it be implemented on Excel?

Please do not hesitate to reply if you need more information from me.

All suggestions will be greatly appreciated.

Thank you!

 

[smssnk]

Dear Team,
Subject code not working in excel micro, i have many time trging but getting error compile error:

 

[himynameisiain]

Brillaint code. I have a slight problem:

1) The subject appears to be case sensitive. I was wondering if there is anyway of making it not case sensitive?
2) Anyway to look for key words in a subject title rather than the full name of the title?

Any help would be appreciated

 

[John_w]

The email subject is checked by this line:

If outMailItem.Subject = subjectFilter Then

1. Use LCase:

If LCase(outMailItem.Subject) = LCase(subjectFilter) Then

2. Use Instr or the Like operator:

If InStr(outMailItem.Subject, subjectFilter, vbTextCompare) > 0 Then

subjectFilter = "*keyword*"
If LCase(outMailItem.Subject) Like LCase(subjectFilter)

The Like operator allows pattern matching. To look for several keywords, extend the If statement with And or Or, or write a function which checks an array of keywords.

 

[himynameisiain]

Hi John, thanks for your help and reply. Unfortunately, i cannot get it to work in the code as im not terribly great at macro's.

I was wondering if there was any chance you could add it in as im confused as some of the subject rows were nearer the top but would now be at the bottom ? Please do not worry if you are unable to if it requires to much time. Thanks in advance.

 

[himynameisiain]

Update: Managed to get the lowercase working formula working. Thanks

Still struggling on the multi words contained in a topic title though

 

[John_w]

As I suggested, use a compound If statement with And or Or.

For 3 keywords, at least one of which must occur in the subject (case insensitive):

If InStr(outMailItem.Subject, "keyword1", vbTextCompare) > 0 Or _
   InStr(outMailItem.Subject, "keyword2", vbTextCompare) > 0 Or _
   InStr(outMailItem.Subject, "keyword3", vbTextCompare) > 0 Then

For 3 keywords, all of which must occur in the subject (case insensitive):

If InStr(outMailItem.Subject, "keyword1", vbTextCompare) > 0 And _
   InStr(outMailItem.Subject, "keyword2", vbTextCompare) > 0 And _
   InStr(outMailItem.Subject, "keyword3", vbTextCompare) > 0 Then

Or combine the Or and And as needed. If you have more keywords, just extend the If statement with more And or Or clauses as shown, or write a function which takes the subject and keywords as parameters and loop through the parameters looking for a match in the subject.

 

[himynameisiain]

John, really appreciate your help so much. I am getting an "object variable or with block variable not set" error. I have used the below code and added an End if to the bottom. Any help would be appreciated.

    Dim OutlookOpened As Boolean
    Dim OutApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outFolder As Outlook.MAPIFolder
    Dim outAttachment As Outlook.Attachment
    Dim outItem As Object
    Dim outMailItem As Outlook.MailItem
    Dim inputDate As String, subjectFilter As String
    Dim saveInFolder As String
    
    saveInFolder = "" & ThisWorkbook.Sheets("SUMMARY").Range("I3").Value & "\"                                'CHANGE FOLDER PATH AS NEEDED
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    
  
 If InStr(outMailItem.Subject, "stock", vbTextCompare) > 0 And _
   InStr(outMailItem.Subject, "check", vbTextCompare) > 0 And _
   InStr(outMailItem.Subject, "jan", vbTextCompare) > 0 Then
    
    'Get or create Outlook object and make sure it exists before continuing
    
    OutlookOpened = False
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set OutApp = New Outlook.Application
        OutlookOpened = True
    End If
    On Error GoTo 0
    
    If OutApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        Exit Sub
    End If
    
    Set outNs = OutApp.GetNamespace("MAPI")
    
    Set outFolder = outNs.Folders("Iain E-Mails").Folders("Inbox")  'CHANGE FOLDER AS NEEDED
    'Set outFolder = outNs.PickFolder                                   'OR USER SELECTS FOLDER

    If Not outFolder Is Nothing Then
        For Each outItem In outFolder.Items
            If outItem.Class = Outlook.OlObjectClass.olMail Then
                Set outMailItem = outItem
                If LCase(outMailItem.Subject) = LCase(subjectFilter) Then
                    Debug.Print outMailItem.Subject
                    For Each outAttachment In outMailItem.Attachments
                        outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
                    Next
                End If
            End If
        Next
    End If

    If OutlookOpened Then OutApp.Quit
    
    Set OutApp = Nothing
    
    
End Sub

 

[John_w]

You have added an extraneous If statement and not changed the If statement in the original code which I referred to in my post #13.

 

[himynameisiain]

Hi Join, im sorry but i am a bit lost. any further help would be appreciated.

 

[Harish Kumar]

Try this code, which you should put in a module in an Excel workbook. You also need to set a reference to the Microsoft (Office) Outlook Library in Tools - References in the VB editor before running or compiling the code.

It assumes the emails are in the Inbox folder (change this part of the code where indicated if not, or use the PickFolder method currently commented out to let the user select the Outlook folder). The emails are expected to have the exact subject "Daily activities: mm/dd/yyyy" where mm/dd/yyyy is the date inputted. The attachments are saved in C:\path\to\folder - change this in the code where indicated to the folder where you want them to be saved.

Public Sub Extract_Outlook_Email_Attachments()

    Dim OutlookOpened As Boolean
    Dim outApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outFolder As Outlook.MAPIFolder
    Dim outAttachment As Outlook.Attachment
    Dim outItem As Object
    Dim outMailItem As Outlook.MailItem
    Dim inputDate As String, subjectFilter As String
    Dim saveInFolder As String
    
    saveInFolder = "C:\path\to\folder\"                                 'CHANGE FOLDER PATH AS NEEDED
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    
    inputDate = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
    If inputDate = "" Then Exit Sub
    
    subjectFilter = "Daily activities: " & Format(inputDate, "dd/mm/yyyy")
    
    'Get or create Outlook object and make sure it exists before continuing
    
    OutlookOpened = False
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set outApp = New Outlook.Application
        OutlookOpened = True
    End If
    On Error GoTo 0
    
    If outApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        Exit Sub
    End If
    
    Set outNs = outApp.GetNamespace("MAPI")
    
    Set outFolder = outNs.Folders("Personal Folders").Folders("Inbox")  'CHANGE FOLDER AS NEEDED
    'Set outFolder = outNs.PickFolder                                   'OR USER SELECTS FOLDER

    If Not outFolder Is Nothing Then
        For Each outItem In outFolder.Items
            If outItem.Class = Outlook.OlObjectClass.olMail Then
                Set outMailItem = outItem
                If outMailItem.Subject = subjectFilter Then
                    Debug.Print outMailItem.Subject
                    For Each outAttachment In outMailItem.Attachments
                        outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
                    Next
                End If
            End If
        Next
    End If

    If OutlookOpened Then outApp.Quit
    
    Set outApp = Nothing

End Sub

Hello,

I am quite satisfy with your post and it is helping me a lot ....
i am sorry if you have answered this query....
So my query is i am getting error when i am changing folder name "Saurabh" under Inbox (Outlook)
Error is - Run time error '-2147221233(8004010f)
Attempted operation failed. An object could not be faund.
and My over all Code is -

Public Sub Extract_Outlook_Email_Attachments()


Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
Dim saveInFolder As String

saveInFolder = "D:\Daily Raw data\Reports\2Affiliate\Raw_file" 'CHANGE FOLDER PATH AS NEEDED
If Right(saveInFolder, 1) <> "" Then saveInFolder = saveInFolder & ""

'inputDate = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
inputDate = Format(Date, "mm/dd/yyyy")
If inputDate = "" Then Exit Sub

subjectFilter = "FW: Data Warehouse: for MMT Global"

'Get or create Outlook object and make sure it exists before continuing

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0

If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")

Set outFolder = outNs.Folders("Saurabh").Folders("Inbox") 'CHANGE FOLDER AS NEEDED
' Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
'Set outFolder = outNs.PickFolder 'OR USER SELECTS FOLDER


If Not outFolder Is Nothing Then
For Each outItem In outFolder.Items
If outItem.Class = Outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.Subject = subjectFilter Then
Debug.Print outMailItem.Subject
For Each outAttachment In outMailItem.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
Next
End If
End If
Next
End If


If OutlookOpened Then outApp.Quit

Set outApp = Nothing
MsgBox "done...!"
End Sub


Pls help ....