loop through a excel range to download email attachments from outlook folder

[abhay_547]

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

Starting 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 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:

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

 

[abhay_547]

can someone help with the above code

 

[abhay_547]

can someone help with the above code

 

[abhay_547]

can someone help with the above code

 

[abhay_547]

Crossposted now on excelforum, link: https://www.excelforum.com/excel-pr...achments-from-outlook-folder.html#post4836739

 

[abhay_547]

can someone help with the above code