Excel macro to download email attachments based email subject lines listed in excel

I have a macro which helps me download the email attachments from outlook based on the list of the email subject lines listed in excel worksheet. Below are changes which i want to make to this macro.

• Define the outlook inbox, actually I want the macro to search the common team shared mailbox instead of personal mailbox
• Define the Save as folder path from a excel cell instead of hard coding the path in the macro
• Define the subject line's only unique part not the entire subject line since it consists of date and some code which changes daily so we can't hard code subject line
• Once the attachment is downloaded the email should be marked as Read.

Code:

---

Sub Downloademailattachementsfromexcellist()Dim olapp As Object
Dim olmapi As Object
Dim olmail As Object
Dim olitem As Object
Dim lrow As Integer
Dim olattach As Object
Dim str As String


Const num As Integer = 6
Const path As String = "C:\HP\" ' i want this to fetch the value from excel worksheet something like ThisWorkbook.Sheets("Email Download").Range("C1").value
Const olFolderInbox As Integer = 6 ' I want to define the common shared mailbox over here...instead of my own personal box. Common mailbox name is IGT Team


Set olp = CreateObject("outlook.application")
Set olmapi = olp.getnamespace("MAPI")
Set olmail = olmapi.getdefaultfolder(num)


If olmail.items.restrict("[UNREAD]=True").Count = 0 Then


    MsgBox ("No Unread mails")


    Else


        For Each olitem In olmail.items.restrict("[UNREAD]=True")
            lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1


            Range("B" & lrow).Value = olitem.Subject ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
           


            If olitem.attachments.Count <> 0 Then


                For Each olattach In olitem.attachments


                    olattach.SaveAsFile path & olattach.Filename
                    ' Once the attachement is downloaded I want the macro to mark the mail as Read


                Next olattach
            End If               
           
           
        Next olitem


End If
End Sub

---

Any luck ? did anyone get the chance to look into the above code.

You don't need const for path. Just use what you commented to set the value for path.

To use another folder, you will need the path. Look at how I got that and used it in this thread: http://www.vbaexpress.com/forum/show...ch-appointment

For the marking read, maybe:

Code:

---

'other stuff
If olitem.attachments.Count <> 0 Then
  olitem.read = True
'other stuff

---

I don't know what you mean by subject line unique parts.

Quote:

---

Originally Posted by Kenneth Hobs

You don't need const for path. Just use what you commented to set the value for path.

To use another folder, you will need the path. Look at how I got that and used it in this thread: http://www.vbaexpress.com/forum/show...ch-appointment

For the marking read, maybe:

Code:

---

'other stuff
If olitem.attachments.Count <> 0 Then
  olitem.read = True
'other stuff

---

I don't know what you mean by subject line unique parts.

---

Subject line unique part means for e.g. the subject line of an email is "Daily Fund Report 04162019 REF548725", now in this the "Daily Fund Report" is the unique part since it doesn't change daily but the date and the REF number changes daily so we have to identify the mails based on the unique part so if the email subject line consists of Daily Fund Report then macro should download it's attachment and mark it as Read.

Frankly your code doesn't make much sense. You have selected a path from a fixed cell in the worksheet when if this is correct you could hard code the path without reference to the sheet, and you are comparing the subject with the empty row after the last row in column A, i.e. Row + 1, so that's never going to achieve anything if there are fewer rows in column B. So get instead the last row in the column you are referencing.

It is also not clear whether the path will exist, so you need to add code to check and if necessary add the path. The shared path will depend on how your system is configured, but I have included code that might work for you.

The code will extract all attachments and that includes images in the message including in the signature, and the code will overwrite any existing attachment of the same name in the folder.

Also I strongly recommend using the function linked from the top of the code rather than create a new Outlook instance.

Given those provisos try the following.

Code:

---

Option Explicit
'++++++ Important ++++++
'Graham Mayor - https://www.gmayor.com - Last updated - 16 Apr 2019
'Use the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to start Outlook
'+++++++++++++++++++++++

Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Const olFolderInbox As Integer = 6    ' I want to define the common shared mailbox over here...instead of my own personal box. Common mailbox name is IGT Team

    Set olApp = OutlookApp()
    Set olNS = olApp.GetNameSpace("MAPI")
    'The following two lines should get the shared folder, but without access to your setup I cannot test it

    'Set olRecip = olNS.CreateRecipient(olNS.CurrentUser.Address)    ' Owner's Name or email address
    'Set olShareInbox = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)

    'so I have used the default inbox for testing
    Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox)
    '-----------------------
    Set xlSheet = ActiveWorkbook.Sheets("Email Download")
    strPath = "C:\HP\" & xlSheet.Range("C1").value & "\"

    If olShareInbox.Items.restrict("[UNREAD]=True").Count = 0 Then
        MsgBox ("No Unread mails")
    Else
        CreateFolders strPath    'ensure the save path is present
        For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1
            If InStr(1, olItem.Subject, xlSheet.Range("B" & lRow).value) > 0 Then  ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
                If olItem.attachments.Count > 0 Then
                    For Each olAttach In olItem.attachments
                        strName = olAttach.FileName
                        olAttach.SaveAsFile strPath & strName
                        olItem.UnRead = False    ' Once the attachment is downloaded I want the macro to mark the mail as Read
                    Next olAttach
                End If
            End If
        Next olItem
    End If
End Sub

Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.CreateFolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub

---

Hi gmayor, I have made a slight tweak to your code .i.e. to access the active outlook session and I have tested it but instead of looping through the subject lines in column B starting row 4, it is just downloading the attachment of only last subject line email in column B. Can we actually loop the macro from row B4 till last row (till where the subject lines are mentioned) and download the attachments for subject line.

Also can we define the shared team inbox name and the folder name inside it from an excel cell instead of hardcoding the name of the folder and shared inbox name in the code.

Apart from this is it possible to download the attachment from a link as well which is embedded in a email body.

Code:

---

Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Const olFolderInbox As Integer = 6    ' I want to define the common shared mailbox over here...instead of my own personal box. Common mailbox name is IGT Team

    Set olApp = OutlookApp("outlook.application") ' this is the line which i tweaked to access outlook.
    Set olNS = olApp.GetNameSpace("MAPI")
    'The following two lines should get the shared folder, but without access to your setup I cannot test it

    'Set olRecip = olNS.CreateRecipient(olNS.CurrentUser.Address)    ' Owner's Name or email address ' can we define the name of the mailbox from an excel worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("F1").Value
    'Set olShareInbox = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)' how can we select a folder inside a shared mailbox and also define the name of the folder from a worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("G1").Value

    'so I have used the default inbox for testing
    Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox)
    '-----------------------
    Set xlSheet = ActiveWorkbook.Sheets("Email Download")
    strPath = "C:\HP\" & xlSheet.Range("C1").value & "\"

    If olShareInbox.Items.restrict("[UNREAD]=True").Count = 0 Then
        MsgBox ("No Unread mails")
    Else
        CreateFolders strPath    'ensure the save path is present
        For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1
            If InStr(1, olItem.Subject, xlSheet.Range("B" & lRow).value) > 0 Then  ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
                If olItem.attachments.Count > 0 Then
                    For Each olAttach In olItem.attachments
                        strName = olAttach.FileName
                        olAttach.SaveAsFile strPath & strName
                        olItem.UnRead = False    ' Once the attachment is downloaded I want the macro to mark the mail as Read
                    Next olAttach
                End If
            End If
        Next olItem
    End If
End Sub

---

Hi gmayor, Any luck ? did you get the chance to look into the above code.

Hi gmayor, Any luck ? did you get the chance to look into the above code.

Hi gmayor, Any luck ? did you get the chance to look into the above code.

Hi All, Did anyone get the chance to look into the above code?

Hi All, Did anyone get the chance to look into the above code ?

Hi All, Did anyone get the chance to look into the above code ?

Repeating the question over and over doesn't get you a reply any quicker. It just causes annoyance. This is not a free programming service, but a resource to help users, and I already did that.
To answer your questions without access to the worksheet is difficult however:

1. Your change to the line

Code:

---

Set olApp = OutlookApp("outlook.application") ' this is the line which i tweaked to access outlook.

---

was inappropriate. The original was correct and sugegsts that you didn't read the comment at the top of the code

Code:

---

'Use the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to start Outlook

---

2.The code doesn't loop through the items in Column B. It loops through the messages and compares them with the lastrow of column B. If you want to compare them with all the items in Column B then you need to set a second loop to check each relevant cell.
3. You can define the name of the folder in the workbook, but it has to match the format in the commented out section, which I cannot test without access to your system.
4. I regret I don't have experience of downloading from a link in a message - however https://stackoverflow.com/questions/...-url-hyperlink might help.

Apologies...and I am extremely sorry for repeatedly asking the question. I really appreciate the help which I got so far. can you please help me with the point 2 to run the second loop. I

2.The code doesn't loop through the items in Column B. It loops through the messages and compares them with the lastrow of column B. If you want to compare them with all the items in Column B then you need to set a second loop to check each relevant cell.

Code:

---

Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Const olFolderInbox As Integer = 6    ' I want to define the common shared mailbox over here...instead of my own personal box. Common mailbox name is IGT Team

    Set olApp = OutlookApp("outlook.application") ' this is the line which i tweaked to access outlook.
    Set olNS = olApp.GetNameSpace("MAPI")
    'The following two lines should get the shared folder, but without access to your setup I cannot test it

    'Set olRecip = olNS.CreateRecipient(olNS.CurrentUser.Address)    ' Owner's Name or email address ' can we define the name of the mailbox from an excel worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("F1").Value
    'Set olShareInbox = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)' how can we select a folder inside a shared mailbox and also define the name of the folder from a worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("G1").Value

    'so I have used the default inbox for testing
    Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox)
    '-----------------------
    Set xlSheet = ActiveWorkbook.Sheets("Email Download")
    strPath = "C:\HP\" & xlSheet.Range("C1").value & "\"

    If olShareInbox.Items.restrict("[UNREAD]=True").Count = 0 Then
        MsgBox ("No Unread mails")
    Else
        CreateFolders strPath    'ensure the save path is present
        For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1

    Dim Rng As Range
      Set Rng = Range("B3", Range("B1").End(xlDown))
      Counter = Rng.Count
      For i = 1 To Counter
  If InStr(1, olItem.Subject, xlSheet.Range("B" & lRow).value) > 0 Then  ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
                If olItem.attachments.Count > 0 Then
                    For Each olAttach In olItem.attachments
                        strName = olAttach.FileName
                        olAttach.SaveAsFile strPath & strName
                        olItem.UnRead = False    ' Once the attachment is downloaded I want the macro to mark the mail as Read
                    Next olAttach
                End If
            End If
        Next olItem
Next i
    End If
End Sub

---

Untested but probably

Code:

---

lRow = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row       
      For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            For iRow = 1 To lRow    'declare the variable iRow as integer
                'lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1
                If InStr(1, olItem.Subject, xlSheet.Range("B" & iRow).value) > 0 Then  ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
                    If olItem.attachments.Count > 0 Then
                        For Each olAttach In olItem.attachments
                            strName = olAttach.FileName
                            olAttach.SaveAsFile strPath & strName
                            olItem.UnRead = False    ' Once the attachment is downloaded I want the macro to mark the mail as Read
                        Next olAttach
                    End If
                    Exit For 'subject found so stop looking
                End If
            Next iRow
        Next olItem

---

Now it's looping through column B but unfortunately if the subject line of email doesn't match exactly with the cell value in column B then it wouldn't download the attachment of the same. I have few subject lines which consists of some code which change daily and hence I am entering only the identical part of that subject line which is same every day for e.g. subject line of the email is Daily Report CRS YYYYMMDD 05422122, so in this case I will just mention the starting text of subject line .i.e. Daily Report CRS and i want the macro to search the email which consists of the aforementioned text. I believe will have to use asterisk sign before and after the name but in the code I am unable add the same.

Code:

---

Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Dim iRow as Integer
Const olFolderInbox As Integer = 6    ' I want to define the common shared mailbox over here...instead of my own personal box. Common mailbox name is IGT Team

    Set olApp = OutlookApp("outlook.application") ' this is the line which i tweaked to access outlook.
    Set olNS = olApp.GetNameSpace("MAPI")
    'The following two lines should get the shared folder, but without access to your setup I cannot test it

    'Set olRecip = olNS.CreateRecipient(olNS.CurrentUser.Address)    ' Owner's Name or email address ' can we define the name of the mailbox from an excel worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("F1").Value
    'Set olShareInbox = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)' how can we select a folder inside a shared mailbox and also define the name of the folder from a worksheet cell .i.e. ThisWorkbook.Sheets("Email Download").Range("G1").Value

    'so I have used the default inbox for testing
    Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox)
    '-----------------------
    Set xlSheet = ActiveWorkbook.Sheets("Email Download")
    strPath = "C:\HP\" & xlSheet.Range("C1").value & "\"

    If olShareInbox.Items.restrict("[UNREAD]=True").Count = 0 Then
        MsgBox ("No Unread mails")
    Else
        CreateFolders strPath    'ensure the save path is present
        For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1
lRow = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row       
      For Each olItem In olShareInbox.Items.restrict("[UNREAD]=True")
            For iRow = 1 To lRow    'declare the variable iRow as integer
                'lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row    ' + 1
                If InStr(1, olItem.Subject, *xlSheet.Range("B" & iRow).value*) > 0 Then  ' each email subject line consists of date or some code which changes daily so I will just mention the unique part of the subject line which remains same daily.
                    If olItem.attachments.Count > 0 Then
                        For Each olAttach In olItem.attachments
                            strName = olAttach.FileName
                            olAttach.SaveAsFile strPath & strName
                            olItem.UnRead = False    ' Once the attachment is downloaded I want the macro to mark the mail as Read
                      Next olAttach
                    End If
                    Exit For 'subject found so stop looking
                End If
            Next iRow
        Next olItem

    End If
End Sub

---

Hi gmayor, did you get the chance to look into the above...I tried using asterisk with & sign but it doesn't seem to work. Can you please advise what is going wrong.

Code:

---

If InStr(1, olItem.Subject, "*" & xlSheet.Range("B" & iRow).value & "*") > 0

---

Hi Gmayor, any luck with the above the query.I tried using asterisk with & sign but it doesn't seem to work. Can you please advise what is going wrong.

Code:

---

        If InStr(1, olItem.Subject, "*" & xlSheet.Range("B" & iRow).value & "*") > 0

---