Extract / Count Outlook Public Folder Emails based on Date Range in Excel

[Carrotkiller]

Hello All

I have put together some code in excel from various sources online(VBA X and others) to extract outlook emails from a series of public folders, its working fine but I would like to amend the code to only extract email based on a date range. At the moment its taking ages to run as its extracting all emails everytime I run it, I only need to run a weeks worth each time.

I will update the week commencing date(start date) on a summary sheet in excel and would like the macro to extract only emails in the folder based on that week(7days).

I'm not sure if I can do that using the method currently used.

Any help with this matter would be greatly appreciated!

Current working code below that is used for 1 of the folder counts.

Regards

Carrotkiller

Sub Inbox1Recieved() 
     '
     '
     'Declare Outlook app and folder object variables.
     
    Dim objOutlook As Object, objnSpace As Object 
    Dim objfolder As Object ', CurrUser As String
    Dim EmailItemCount As Integer, I As Integer, EmailCount As Integer 
     'CurrUser As String
    Set objOutlook = CreateObject("Outlook.Application") 
    Set objnSpace = objOutlook.GetNamespace("MAPI") 
    Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - PPNB").Folders("Inbox") 
     
     'Verify existence of Inbox folder as direct subfolder of Personal Folders.
    On Error Resume Next 
     'Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - No Reply").Folders("Inbox")
    If Err.Number <> 0 Then 
        Err.Clear 
        MsgBox "No such folder named Inbox.", 48, "Cannot continue" 
        Exit Sub 
    End If 
    Application.ScreenUpdating = False 
    Workbooks("NB Weekly Email Report").Sheets("Summary").Activate 
    Range("B18").Value = Now() 
    Workbooks("NB Weekly Email Report").Sheets("Pending").Activate 
     ' the items.count command returns the count for the exisiting folder through which the code is looping across
     
     
    EmailItemCount = objfolder.Items.Count 
    I = 0: EmailCount = 0 
     ' read e-mail information
    While I < EmailItemCount 
        I = I + 1 
        If I Mod 50 = 0 Then Application.StatusBar = "Reading e-mail messages " & _ 
        Format(I / EmailItemCount, "0%") & "..." 
        With objfolder.Items(I) 
            EmailCount = EmailCount + 1 
            Cells(EmailCount + 1, 1).Formula = .Subject 
            Cells(EmailCount + 1, 2).Formula = Format(.ReceivedTime, "dd.mm.yyyy hh:mm:ss") 
            Cells(EmailCount + 1, 3).Formula = .Attachments.Count 
            Cells(EmailCount + 1, 4).Formula = Not .UnRead 
            Cells(EmailCount + 1, 5).Formula = .SenderName 
            Cells(EmailCount + 1, 6).Formula = .ReceivedTime 
            Cells(EmailCount + 1, 7).Formula = .LastModificationTime 
            Cells(EmailCount + 1, 8).Formula = .ReplyRecipientNames 
            Cells(EmailCount + 1, 9).Formula = .SentOn 
            Cells(EmailCount + 1, 10).Value = objfolder.Name 
             ' Cells(EmailCount + 1, 5).Formula = .Body
             'Cells(14).Value = objfolder.Name
             
        End With 
    Wend 
    Application.Calculation = xlCalculationAutomatic 
     'Set OLF = Nothing
    Set objfolder = Nothing 
     
    Call Inbox2Replied1 
     
End Sub 

VBA tags courtesy of www.thecodenet.com

[JP2112]

Use the Items.Restrict Method to filter the collection by date. Here are some examples:

http://msdn.microsoft.com/en-us/library/bb220369(v=office.12).aspx

[Carrotkiller]

Thanks for the reply Jp, I'll see if I can get that working tomorrow.

Cheers

[Carrotkiller]

Hi JP

My Outlook VBA knowledge is limited, could not get it working,tried another way-but still seems to be extracting all emails in the folder!!

Any ideas on how to amend the below to get it working?

Many Thanks

Sub Inbox1Recieved() 
     '
     '
     'Declare Outlook app and folder object variables.
     
    Dim objOutlook As Object, objnSpace As Object 
    Dim objfolder As Object ', CurrUser As String
    Dim EmailItemCount As Integer, I As Integer, EmailCount As Integer 
     'CurrUser As String
    Dim Mydate As Date 
    Set objOutlook = CreateObject("Outlook.Application") 
    Set objnSpace = objOutlook.GetNamespace("MAPI") 
    Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - PPNB").Folders("Inbox") 
    Mydate = Sheets("Summary").Range("F4").Value 'format = 03/10/2011 00:00:00
     
     'Verify existence of Inbox folder as direct subfolder of Personal Folders.
    On Error Resume Next 
     'Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - No Reply").Folders("Inbox")
    If Err.Number <> 0 Then 
        Err.Clear 
        MsgBox "No such folder named Inbox.", 48, "Cannot continue" 
        Exit Sub 
    End If 
    Application.ScreenUpdating = False 
    Workbooks("NB Weekly Email Report").Sheets("Summary").Activate 
    Range("B18").Value = Now() 
    Workbooks("NB Weekly Email Report").Sheets("Pending").Activate 
     ' the items.count command returns the count for the exisiting folder through which the code is looping across
     
    EmailItemCount = objfolder.Items.Count 
     
    If EmailItemCount = "[RecievedTime] <= MyDate And > Mydate+7" Then 
         
         
         'EmailItemCount = objfolder.Items.Count
        I = 0: EmailCount = 0 
         ' read e-mail information
        While I < EmailItemCount 
            I = I + 1 
            If I Mod 50 = 0 Then Application.StatusBar = "Reading e-mail messages " & _ 
            Format(I / EmailItemCount, "0%") & "..." 
            With objfolder.Items(I) 
                EmailCount = EmailCount + 1 
                Cells(EmailCount + 1, 1).Formula = .Subject 
                Cells(EmailCount + 1, 2).Formula = Format(.ReceivedTime, "dd.mm.yyyy hh:mm:ss") 
                Cells(EmailCount + 1, 3).Formula = .Attachments.Count 
                Cells(EmailCount + 1, 4).Formula = Not .UnRead 
                Cells(EmailCount + 1, 5).Formula = .SenderName 
                Cells(EmailCount + 1, 6).Formula = .ReceivedTime 
                Cells(EmailCount + 1, 7).Formula = .LastModificationTime 
                Cells(EmailCount + 1, 8).Formula = .ReplyRecipientNames 
                Cells(EmailCount + 1, 9).Formula = .SentOn 
                Cells(EmailCount + 1, 10).Value = objfolder.Name 
                 '   Cells(EmailCount + 1, 5).Formula = .Body
                 'Cells(14).Value = objfolder.Name
                 
            End With 
        Wend 
         
    End If 
     
    Application.Calculation = xlCalculationAutomatic 
     'Set OLF = Nothing
    Set objfolder = Nothing 
     
     'Call Inbox2Replied1

VBA tags courtesy of www.thecodenet.com

[JP2112]

You must apply the filter to the Items collection you want to iterate. Since objfolder points to the folder, create a new object that points to that folder's Items collection, i.e.

 
Dim itms As Outlook.Items 
Set itms = objfolder.Items 

VBA tags courtesy of www.thecodenet.com

Now you have an Items collection on which to use the Restrict method (based on the link I posted earlier).

What I would do is use a second Items object to hold the filtered collection, like this:

 
Dim filteredItms As Outlook.Items 
Set filteredItms = itms.Restrict("[ReceivedTime] > '" & Mydate & "' And [ReceivedTime] < '" & Mydate + 7 & "'") 

VBA tags courtesy of www.thecodenet.com

Now you can check itms.Count, loop through the filtered collection and write each email's properties to Excel.

[Carrotkiller]

Hi JP

Thanks for taking the time to reply and supplying the code snippits, I managed to get it working with your help

Final code below for anyone interested:

Sub Inbox1Recieved() 
     '
     '
     'Declare Outlook app and folder object variables.
     
    Dim objOutlook As Object, objnSpace As Object 
    Dim objfolder As Object 
    Dim EmailItemCount As Integer, I As Integer, EmailCount As Integer 
    Dim Mydate As Date 
    Dim Mydate2 As Date 
    Dim itms As Outlook.Items 
    Dim filteredItms As Outlook.Items 
    Mydate = Sheets("Summary").Range("F4").Value 'format = 03/10/2011 00:00:00
    Mydate2 = Sheets("Summary").Range("L4").Value 'format = 03/10/2011 00:00:00
     
    Set objOutlook = CreateObject("Outlook.Application") 
    Set objnSpace = objOutlook.GetNamespace("MAPI") 
    Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - PPNB").Folders("Inbox") 
    Set itms = objfolder.Items 
    Set filteredItms = itms.Restrict("[ReceivedTime] > '" & Mydate & "' And [ReceivedTime] < '" & Mydate2 + 1 & "'") 
     
     
     'Verify existence of Inbox folder as direct subfolder of Personal Folders.
    On Error Resume Next 
     
    If Err.Number <> 0 Then 
        Err.Clear 
        MsgBox "No such folder named Inbox.", 48, "Cannot continue" 
        Exit Sub 
    End If 
    Application.ScreenUpdating = False 
    Workbooks("NB Weekly Email Report").Sheets("Summary").Activate 
    Range("B18").Value = Now() 
    Workbooks("NB Weekly Email Report").Sheets("Pending").Activate 
     
    EmailItemCount = filteredItms.Count 
     
    I = 0: EmailCount = 0 
     ' read e-mail information
    While I < EmailItemCount 
        I = I + 1 
        If I Mod 50 = 0 Then Application.StatusBar = "Reading e-mail messages " & _ 
        Format(I / EmailItemCount, "0%") & "..." 
        With filteredItms(I) 
            EmailCount = EmailCount + 1 
            Cells(EmailCount + 1, 1).Formula = .Subject 
            Cells(EmailCount + 1, 2).Formula = Format(.ReceivedTime, "dd.mm.yyyy hh:mm:ss") 
            Cells(EmailCount + 1, 3).Formula = .Attachments.Count 
            Cells(EmailCount + 1, 4).Formula = Not .UnRead 
            Cells(EmailCount + 1, 5).Formula = .SenderName 
            Cells(EmailCount + 1, 6).Formula = .ReceivedTime 
            Cells(EmailCount + 1, 7).Formula = .LastModificationTime 
            Cells(EmailCount + 1, 8).Formula = .ReplyRecipientNames 
            Cells(EmailCount + 1, 9).Formula = .SentOn 
            Cells(EmailCount + 1, 10).Value = objfolder.Name 
             
        End With 
    Wend 
     
     
     
    Application.Calculation = xlCalculationAutomatic 
    Set objfolder = Nothing 
     
     
    Call Inbox2Replied1 
     
End Sub 

VBA tags courtesy of www.thecodenet.com

Thanks Again

Regards

Carrotkiller

[JP2112]

Congrats and +1 to you for your effort!