Need to Filter mail based on Date RRS feed

  • Question

  • Hi Team,

    I've below code which is working fine except the Ldate part. I need to fetch mails that i received today.

    Sub Unzip()
        '''Variables for the main functionality
        Dim app As Object
        Dim NS As Object
        Dim InboX As Object
        Dim SubFolder As Object
        Dim MsG As Object
        Dim AtcHmt As Object
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        Dim f As Boolean
        '''Variables for unzipping
        Dim FSO As Object
        Dim ShellApp As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ShellApp = CreateObject("Shell.Application")
        Dim FileNameFolder As Variant
        Dim FileName As Variant
        Dim Ldate As String
        Ldate = Date
        '''Define the Outlook folder you want to scan
        On Error Resume Next
        Set app = GetObject(Class:="Outlook.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Outlook.Application")
            f = True
        End If
        On Error GoTo ErrHandler
        Set NS = app.GetNamespace("MAPI")
        Set InboX = NS.GetDefaultFolder(6) ' olFolderInbox
        Set SubFolder = InboX.Folders("TEST")
        '''Define the folder where you want to save attachments
        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"

        '''Define the hours in between which you want to apply the extraction
        oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
                                "Example: 9AM", ("Shadowserver report"), "9AM"))
        oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
                                "Example: 6PM", ("Shadowserver report"), "6PM"))

        For Each MsG In SubFolder.Items
        If Ldate = MsG.SentOn Then
           ReceivedHour = MsG.ReceivedTime
            If oFrom <= TimeValue(ReceivedHour) And _
                TimeValue(ReceivedHour) <= oEnd Then
                For Each AtcHmt In MsG.Attachments
                    FileName = AtcHmt.FileName
                    If LCase(Right(FileName, 3)) = "zip" Then
                        FileName = FileNameFolder & FileName
                        AtcHmt.SaveAsFile FileName

                        ShellApp.Namespace(FileNameFolder).CopyHere _

                        Kill FileName
                        On Error Resume Next
                        FSO.Deletefolder Environ$("Temp") & "\Temporary Directory*", True
                    End If
                Next AtcHmt
            End If
        End If
        Next MsG

    Call ImportCSVs
        On Error Resume Next
        If f Then app.Quit
        Exit Sub

        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    Friday, June 2, 2017 10:40 AM


  • Hello KaiFel,

    >>I need to fetch mails that i received today

    I suggest you use Items.Restrict for filtering mails. You could use a filter string to filter mails and return a items collection which match the filter. Here is the example.

    tFrom = Ldate + oFrom 'start time, such as 6/5/2017 9:00AM 
        tEnd = Ldate + oEnd 'end time, such as 6/5/2017 6:00PM
        sFilter = "[ReceivedTime]>'" & Format(tFrom, "ddddd h:nn AMPM") & "' And [ReceivedTime]<'" & Format(tEnd, "ddddd h:nn AMPM") & "'"
        Dim itms As Outlook.Items
        Set itms = SubFolder.Items.Restrict(sFilter)
        For Each MsG In itms
        For Each AtcHmt In MsG.Attachments
        Next AtcHmt
        Next MsG

    For your code above,  you defined the Ldate a date value but MsG.SentOn is a time value. I think you need set them same format so they could be compared. Here is the example.

    Ldate = Format(Date, "yyyy-mm-dd")
    If Ldate = Format(MsG.SentOn, "yyyy-mm-dd") Then 



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact

    • Proposed as answer by Chenchen LiModerator Tuesday, June 13, 2017 7:12 AM
    • Marked as answer by KalFel Thursday, June 22, 2017 4:18 AM
    Monday, June 5, 2017 7:23 AM