none
Import email attchments to a Folder - by date RRS feed

  • Question

  • Hi all ,

    I have a VBA code to import email attachments it is working fine . just needed few more features in it.
    My program it identifies a folder name (Autozone print) and collate all the excel attachments and save to a folder (X).
    it is fine so far . I would like that more dynamic for example : Autozone print has 100 emails from last two weeks now I want only specific dated emails like ( I want emails from 09/12/2016 to 09/15/2016) only .

    Could some one advice on it . please find below code for your reference .


    Sub SaveAttachmentsToFolder()
        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 i As Integer
        Dim varResponse As VbMsgBoxResult
        Set ns = GetNamespace("MAPI")
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
        Set SubFolder = Inbox.Folders("Autozon Print") ' Enter correct subfolder name.
        i = 0
    ' Check subfolder for messages and exit of none found
        If SubFolder.Items.Count = 0 Then
            MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
                   "Nothing Found"
            Exit Sub
        End If
    ' Check each message for attachments
        For Each Item In SubFolder.Items
            For Each Atmt In Item.Attachments
    ' Check filename of each attachment and save if it has "xls" extension
                If Right(Atmt.FileName, 3) = "xls" Then
                ' This path must exist! Change folder name as necessary.
                    FileName = "D:\Users\703171509\Documents\Testing\" & _
                        Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    i = i + 1
                End If
            Next Atmt
        Next Item
    ' Show summary message
        If i > 0 Then
            varResponse = MsgBox("I found " & i & " attached files." _
            & vbCrLf & "I have saved them into the D:\Users\703171509\Documents\Testing" _
            & vbCrLf & vbCrLf & "Would you like to view the files now?" _
            , vbQuestion + vbYesNo, "Finished!")
    ' Open Windows Explorer to display saved files if user chooses
            If varResponse = vbYes Then
                Shell "Explorer.exe /e,D:\Users\703171509\Documents\Testing\", vbNormalFocus
            End If
        Else
            MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        End If
    ' Clear memory
    SaveAttachmentsToFolder_exit:
        Set Atmt = Nothing
        Set Item = Nothing
        Set ns = Nothing
        Exit Sub
    ' Handle Errors
    SaveAttachmentsToFolder_err:
        MsgBox "An unexpected error has occurred." _
            & vbCrLf & "Please note and report the following information." _
            & vbCrLf & "Macro Name: GetAttachments" _
            & vbCrLf & "Error Number: " & Err.Number _
            & vbCrLf & "Error Description: " & Err.Description _
            , vbCritical, "Error!"
        Resume SaveAttachmentsToFolder_exit
    End Sub
    

    Monday, September 26, 2016 10:44 PM

Answers

  • Hi,

    Add the following Restrict in your code

    Dim filter As String
        filter = "[ReceivedTime]>'" & Format("9/12/2016", "ddddd h:nn") & "'" _
        & "AND [ReceivedTime]<'" & Format("9/15/2016", "ddddd h:nn") & "'"
    FilterItems = SubFolder.Items.Restrict(filter)
        For Each Item In FilterItems
    For more information, please visit Items.Restrict Method (Outlook)

    Tuesday, September 27, 2016 5:59 AM
    Moderator