Consulting

Results 1 to 18 of 18

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

  1. #1

    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.


    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

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

  3. #3
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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:
    '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.

  4. #4
    Quote Originally Posted by Kenneth Hobs View Post
    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:
    '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.

  5. #5
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    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.

    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

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

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

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

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

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

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

  13. #13
    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
    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
    '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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  14. #14
    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.

    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

  15. #15
    Untested but probably

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  16. #16
    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.

    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

  17. #17
    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.
    If InStr(1, olItem.Subject, "*" & xlSheet.Range("B" & iRow).value & "*") > 0

  18. #18
    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.
     	If InStr(1, olItem.Subject, "*" & xlSheet.Range("B" & iRow).value & "*") > 0

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •