dcsimg
Results 1 to 14 of 14

Thread: download email attachments based on the subject line and folder names from a worksht

  1. #1

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    download email attachments based on the subject line and folder names from a worksht

    I got a list of email attachements which i need to download from different folders of outlook in a excel sheet in the below order.

    data is in range Row 2 to 10 but can be more in future
    Column A: File / attachment name
    Column B: Email Subject Line
    Column C: Outlook Folder Name
    Column D: Save as location for attachements (different for each)

    Now I have below function which I got through google search which I want to use, below is what i have put together so far, also I want to add the subject line and filename as string (since I want to name the attachment as its mentioned in the worksheet while saving) which is missing in the function:

    Code:
    Sub Downloademailattachments ()
    
    Dim x As Integer
    Dim Attachmentname As String
    Dim Outlookfolder As String
    Dim Subjectline As String
    Dim Filesaveaspath As String
    
    
    
    
             
          NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
           Range("A2").Select
        
          For x = 1 To NumRows
             Attachmentname = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,1)).Value
    Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,2)).Value
    Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
    Filesaveaspath = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
           
    
    SaveEmailAttachmentsToFolder Outlookfolder, "xls", Filesaveaspath
             ActiveCell.Offset(1, 0).Select
          
    Next
    
    
    
    End Sub
    
    
    
    
    Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                     ExtString As String, DestFolder As String)
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
    
        On Error GoTo ThisMacro_err
    
    
        Set ns = GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
        Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
    
    
        I = 0
        ' Check subfolder for messages and exit of none found
        If SubFolder.Items.Count = 0 Then
            MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
                   vbInformation, "Nothing Found"
            Set SubFolder = Nothing
            Set Inbox = Nothing
            Set ns = Nothing
            Exit Sub
        End If
    
    
        'Create DestFolder if DestFolder = ""
        If DestFolder = "" Then
            Set wsh = CreateObject("WScript.Shell")
            Set fs = CreateObject("Scripting.FileSystemObject")
            MyDocPath = wsh.SpecialFolders.Item("mydocuments")
            DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
            If Not fs.FolderExists(DestFolder) Then
                fs.CreateFolder DestFolder
            End If
        End If
    
    
        If Right(DestFolder, 1) <> "\" Then
            DestFolder = DestFolder & "\"
        End If
    
    
        ' Check each message for attachments and extensions
        For Each Item In SubFolder.Items
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End If
            Next Atmt
        Next Item
    
    
        ' Show this message when Finished
        If I > 0 Then
            MsgBox "You can find the files here : " _
                 & DestFolder, vbInformation, "Finished!"
        Else
            MsgBox "No attached files in your mail.", vbInformation, "Finished!"
        End If
    
    
        ' Clear memory
    ThisMacro_exit:
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Set fs = Nothing
        Set wsh = Nothing
        Exit Sub
    
    
        ' Error information
    ThisMacro_err:
        MsgBox "An unexpected error has occurred." _
             & vbCrLf & "Please note and report the following information." _
             & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
             & vbCrLf & "Error Number: " & Err.Number _
             & vbCrLf & "Error Description: " & Err.Description _
             , vbCritical, "Error!"
        Resume ThisMacro_exit
    
    
    End Sub

  2. #2
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    from the code it appears it should save all .xls attachments, but does not in anyway use the attachment file name in column A

    depending on the number of emails in outlook folders there may be much better ways than looping all the folder items, you can use the items.restrict method, to limit the number of items to match the subject line
    Code:
        set sitems = subfolder.items.restrict("[subject]='" & subj & "'")
        For Each Item In sitems
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End If
            Next Atmt
        Next Item
    where subj is an additional parameter to the function, from the calling procedure

    ActiveCell.Offset(1, 0).Select
    there is no need for this line
    also it would be better not to create an instance of outlook for every line in the worksheet, better to just have one instance and use the for all iterations
    i believe i would just integrate the function in to the main procedure, though you could open an outlook instance in the main procedure, then pass the outlook subfolder to the function
    Last edited by westconn1; Feb 9th, 2018 at 06:50 AM.
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  3. #3

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    ok. I have made the below changes, but where do i capture the Outlook folder name since its not just one outlook folder we need to loop through different outlook folder and download the attachments and rather than looping through every folder, it's better to look into the folders which are listed in the column C, also how can we make sure that we download only the most recent date attachements from the folders since the mails with same subject are received daily.

    Code:
    Sub Downloademailattachments()
    
    Dim x As Integer
    Dim Outlookfolder As String
    Dim Subjectline As String
    Dim DestFolder As String
    
    NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
    Range("A2").Select
        
          For x = 1 To NumRows
    Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
    Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
    DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
                 
    Set sitems = subfolder.items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.Filename, Len(ExtString))) = LCase(ExtString) Then
                    Filename = DestFolder & Atmt.Filename
                    Atmt.SaveAsFile Filename
                    I = I + 1
                End If
            Next Atmt
        Next Item
    
    Next
      
    End Sub

  4. #4
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    i made some changes to your procedure, i also noted that you do not have an outlook application object, so possibly some of the original code was written in outlook, for the outlook variables to be valid would require a reference to outlook, else change the variables to object, i have not tested the code as posted, so may contain some typo or code error, i fixed or changed anything i noticed that did not look right,

    Code:
    Sub Downloademailattachments()
    
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 1 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
        DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
        ExtString = ".xls"
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                     
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & Atmt.FileName
                    'if destfolder does not have a trailing \ then one would need to be appended to the path
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End If
            Next Atmt
        Next Item
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    End Sub
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  5. #5

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    Ok. i had to make a small tweak and it works now, the only thing is that if i have to download the files with multiple extensions at one go then how do i add the same to the code. for e.g. i have *.csv, *.xls, *.txt and *.xml this four extension file type attachments are expected then how can we include the same.


    Code:
    Sub Downloademailattachments()
    
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 1 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
        Filter = "[Unread] = True"
         Set Items = olFolder.Items.Restrict(Filter)
                     
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & Atmt.FileName
                    'if destfolder does not have a trailing \ then one would need to be appended to the path
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End If
            Next Atmt
        Next Item
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    End Sub]
    Last edited by abhay_547; Feb 12th, 2018 at 01:58 PM.

  6. #6
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    change attachment loop like
    Code:
            For Each Atmt In Item.Attachments
                select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
                  case ".xls", ".csv", ".pdf", ".xlsx"
                    FileName = DestFolder & Atmt.FileName
                    'if destfolder does not have a trailing \ then one would need to be appended to the path
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End select
            Next Atmt
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  7. #7

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    Ok. I have replaced the above piece of code but now it doesn't working and doesn't show any error msg as well. I checked if the destination folder is ending with "\" and it is ending with "\" and everything else is same but it's not working, apart from this i have also tried to declare the extn case as string because i don't want to hardcode the extensions but it didn't work so i have commented it out for now.


    Code:
    Sub Downloademailattachments()
    
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 1 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        'ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
            For Each Atmt In Item.Attachments
                select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
               ' dim fileextn As string
                'fileextn = ThisWorkbook.Sheets("Sheet1").Range("B2").value ' cell B2 will have the text ".xls", ".csv", ".pdf", ".xlsx"
                'case fileextn  
                  case ".xls", ".csv", ".pdf", ".xlsx"
                    FileName = DestFolder & Atmt.FileName
                    'if destfolder does not have a trailing \ then one would need to be appended to the path
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End select
            Next Atmt
        Next Item
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    End Sub]

  8. #8
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    i screwed up the right statement,
    decided mid is better anyway

    this only partial code to show the changes
    Code:
        extstring = ".xlsx, .csv, .txt," 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.Restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
            For Each atmt In Item.Attachments
                fext = Mid(atmt.FileName, InStrRev(atmt.FileName, "."))
                Select Case True
                  Case InStr(extstring, fext & ",")
                    FileName = DestFolder & atmt.FileName
                    atmt.SaveAsFile FileName
                    i = i + 1  ' i am not sure what the counter is used for
                End Select
            Next atmt
        Next Item
    i changed the select case to use variable, this should now allow a multiple filetype string, needs to have a comma or someother separator character, immediately after each fileextn (including the last)
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  9. #9

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    Thanks a lot. it's working now, but the only issue is that if the subject line of the email don't have the date then it may end up downloading previous day attachment. see below 2 examples.

    Email subject line 1: Account Balances COB 02/13/2018 (in this case, i have applied a formula in the subject line column (column B) concatenating text and date .i.e. Account balance COB and today minus 1

    Email subject line 2: Outstanding Dues (this mail subject line doesn't have the date so in this case its the same every day and if i expect this mail 10am everyday then i will go ahead and run it at 10.05am everyday so if the mail has not yet arrived then it will download previous day mail attachment.

    To tackle this issue, i am planning to include a column called Mail Date (Column E) and formulate it with expected date .i.e. if its yesterday COB then today minus 1 and it comes in 2 days then today -2 will take workday to avoid weekend's, so how can we refer the macro to this mail date column

    and i want to include also a column at the end (Column F) as Download Status, if the file gets downloaded then it will get populated with the text "File Downloaded Successfully" and if not then it will get populated with the text "Email not found". for error, i was trying to include the below errhandler but believe i am not adding it in the right place, hence its not working. can you advise.



    Code:
    On Error Goto Errhandler
    
    ErrHandler:
         ThisWorkbook.Sheets("Sheet1").cells(x,6).value = "Email Not found"
    Code:
    Sub Downloademailattachments()
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
    Dim MailDate As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 5 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                           
        extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
        On Error GoTo ErrHandler
            For Each Atmt In Item.Attachments
                fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
                Select Case True
                  Case InStr(extstring, fext & ",")
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1  ' i am not sure what the counter is used for
                End Select
            Next Atmt
    ErrHandler:
         ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
        Next Item
                 
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    End Sub

  10. #10
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    you could use some flag to indicate if the mail has already been processed
    also message properties have a sentdate you could possibly make use of
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  11. #11

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    Ok. thanks. should it be something like below.. also can you help with the error handler. thanks again

    Code:
    Sub Downloademailattachments()
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
    Dim MailDate As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 5 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                           
        extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
        On Error GoTo ErrHandler
         If item.receivedtime = MailDate then
            For Each Atmt In Item.Attachments
                fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
                Select Case True
                  Case InStr(extstring, fext & ",")
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1  ' i am not sure what the counter is used for
                End Select
            Next Atmt
    ErrHandler:
         ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
        Next Item
                 
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    Else 
    End  if
    
    End Sub

  12. #12
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    If item.receivedtime = MailDate then
    looks like you need an end if somewhere, after next atmt?

    errhandler will run every time regardless of whether there is an error, so all rows will show email not found
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  13. #13

    Thread Starter
    Hyperactive Member
    Join Date
    Sep 2009
    Posts
    280

    Re: download email attachments based on the subject line and folder names from a work

    ok. I have updated it for received time. where should i move the errhandler then.


    Code:
    Sub Downloademailattachments()
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
    Dim MailDate As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    For x = 5 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                           
        extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
        On Error GoTo ErrHandler
         If item.receivedtime = MailDate then
            For Each Atmt In Item.Attachments
                fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
                Select Case True
                  Case InStr(extstring, fext & ",")
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1  ' i am not sure what the counter is used for
                End Select
            Next Atmt
    
    Else 
    End  if
    
    ErrHandler:
         ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
        Next Item
                 
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    
    
    End Sub

  14. #14
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,821

    Re: download email attachments based on the subject line and folder names from a work

    think in this case i would use in-line error handling, for each email

    Code:
    Sub Downloademailattachments()
    Dim x As Integer
    Dim OutlookfolderInInbox As String
    Dim Subjectline As String
    Dim DestFolder As String
    Dim MailDate As String
        Dim ns As Namespace
        Dim Inbox As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim MyDocPath As String
        Dim I As Integer
        Dim wsh As Object
        Dim fs As Object
    
        Set olook = CreateObject("outlook.application")
        Set ns = olook.GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    
    NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
    ' if you want to start at row 2, change to for x = 2 to numrows
    On Error resume next
    For x = 5 To NumRows
        Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
        OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
        DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
        MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
                           
        extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
        Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
                        
        Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
        For Each Item In sitems
    
         If item.receivedtime = MailDate then
            For Each Atmt In Item.Attachments
                fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
                Select Case True
                  Case InStr(extstring, fext & ",")
                    FileName = DestFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1  ' i am not sure what the counter is used for
                End Select
            Next Atmt
    
    Else 
    End  if
    
       if not err.number = 0 then
         ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Some error occurred"
         err.clear
       end if
        Next Item
                 
    Next x
    Set Inbox = Nothing
    Set ns = Nothing
    ' olook.quit  'if required
    Set olook = Nothing
    End Sub
    this should work ok for any error saving the attachments, and allows the code to continue for next rows, but does nothing for other parts of the code so i moved the on error forward to encompass finding the outlook folder as well, some separate error handler may be good for the setting the outlook objects as without them nothing will work
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

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
  •  



Featured


Click Here to Expand Forum to Full Width