Consulting

Results 1 to 7 of 7

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

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    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]

  2. #2
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    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
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

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

    Cheers

  4. #4
    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]

  5. #5
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    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.
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

  6. #6
    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

  7. #7
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    Congrats and +1 to you for your effort!
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •