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

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

[vba]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]

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

http://msdn.microsoft.com/en-us/libr...ffice.12).aspx

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

Cheers

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!! :banghead:

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

Many Thanks

[VBA]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]

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.

[vba]
Dim itms As Outlook.Items
Set itms = objfolder.Items
[/vba]

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:

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

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

Hi JP

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

Final code below for anyone interested:

[vba]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]

Thanks Again

Regards

Carrotkiller

Congrats and +1 to you for your effort!