-
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!!
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
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!
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules