Be the first user to complete this post
|
Add to List |
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:
- Download the Attachmentfetcher.xlsm from the link provided at the top and at the bottom of this article.
- Open the Attachmentfetcher.xlsm
- Enter the Mail subject keyword here I have entered “Very Specific Subject”
- Enter the Local path in your system where you want to download all the attachments
- Click the “Fetch” button
- 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:
- VBA-Excel: Open and Print the Word Document
- Send Mail With Link to a Workbook, From MS Outlook using Excel.
- Excel-VBA : Prevent Changing the WorkSheet Name
- VBA-Excel: Convert Numbers (Rupees) into Words OR Text - Updated Till 1000000 Crore With Decimal Numbers
- VBA-Excel: Convert Numbers (Rupees) into Words OR Text - Updated Till 1000000 Crore With Decimal Numbers