VBA-Excel — AttachmentFetcher — Download all the Attachments from All the Mails of Specific Subject in Microsoft Outlook .

Download Link :AttachmentFetcher

If you want to download the attachments from all the mails in your Microsoft outlook which has a specific subject name. I am very sure if you have 1000 of mails then you don’t want to do it manually. So here is the Attachmentfetcher which does exactly the same.

How to use it:

1. Down­load the Attachmentfetcher.xlsm from the link pro­vided at the top and at the bot­tom of this article.
2. Open the Attachmentfetcher.xlsm
3. Enter the Mail subject keyword here I have entered “Very Specific Subject”
4. Enter the Local path in your system where you want to download all the attachments
5. Click the “Fetch” button
6. That’s it ,, its done. You don’t actually need this step J

NOTE: All the Attachments will have a random number appended at the name , just to avoid the collisions if two or more attachment has the same name.

Example :

• All Mails

• Set the subject name and local path

• Results

Download Link :AttachmentFetcher

Complete Code:

Sub sumit()

    readMails

End Sub


Function readMails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olItem As Outlook.MailItem
    Dim i As Integer
    Dim b As Integer
    Dim olInbox  As Outlook.MAPIFolder
    Dim olFolder As Outlook.MAPIFolder
    Dim lngCol As Long
    Dim oMsg As Outlook.MailItem
    Dim mainWB As Workbook
    Dim keyword
    Dim Path
    Dim Count
    Dim Atmt
    Dim f_random
    Dim Filename
    'Dim olInbox As inbo
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")

     Set mainWB = ActiveWorkbook

    Set olInbox = olNamespace.GetDefaultFolder(Outlook.olFolderInbox)
    Dim oItems As Outlook.Items
   Set oItems = olInbox.Items
    mainWB.Sheets("Main").Range("A:A").Clear
    mainWB.Sheets("Main").Range("B:B").Clear
    mainWB.Sheets("Main").Range("A1,B1").Interior.ColorIndex = 46
    Path = mainWB.Sheets("Main").Range("J5").Value
    keyword = mainWB.Sheets("Main").Range("J3").Value
    mainWB.Sheets("Main").Range("A1").Value = "Number"
    mainWB.Sheets("Main").Range("B1").Value = "Subject"
    mainWB.Sheets("Main").Range("A1,B1").Borders.Value = 1



    'MsgBox olInbox.Items.Count
   Count = 2
    For i = 1 To oItems.Count
        If TypeName(oItems.Item(i)) = "MailItem" Then
            Set oMsg = oItems.Item(i)

             If InStr(1, oMsg.Subject, keyword, vbTextCompare) > 0 Then
             'MsgBox "asfsdfsdf"
                    'MsgBox oMsg.Subject
                    mainWB.Sheets("Main").Range("A" & Count).Value = Count - 1
                    mainWB.Sheets("Main").Range("B" & Count).Value = oMsg.Subject
                    For Each Atmt In oMsg.Attachments
                    f_random = Replace(Replace(Replace(Now, " ", ""), "/", ""), ":", "") & "_"
                    Filename = Path & f_random & Atmt.Filename
                    'MsgBox Filename
                    Atmt.SaveAsFile Filename
                    FnWait (1)
                    Next Atmt
                    Count = Count + 1
             End If
        End If

    Next


End Function
Function FnWait(intTime)

    Dim newHour
    Dim NewMinute
    Dim newSecond
    Dim waitTime


    newHour = Hour(Now())

    NewMinute = Minute(Now())

    newSecond = Second(Now()) + intTime

     waitTime = TimeSerial(newHour, NewMinute, newSecond)

 Application.Wait waitTime

End Function

Also Read:

1. Excel-VBA : Send a Mail using Predefined Template From MS Outlook Using Excel
2. VBA-Excel: Appending Text to an Existing Word Document - at the End
3. VBA-Excel: SUDOKU Solver
4. VBA-Excel: Convert Numbers (Dollars, Euros) into Words or Text - Till Trillions
5. Excel-VBA : Prevent Adding New Worksheet