Microsoft Excel Webinar

Results 1 to 7 of 7

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

  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

    VB:
    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 
    
    
    Formatting tags added by mark007

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

    VB:
    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
    
    
    Formatting tags added by mark007

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

    VB:
     
    Dim itms As Outlook.Items 
    Set itms = objfolder.Items 
    
    
    Formatting tags added by mark007
    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:

    VB:
     
    Dim filteredItms As Outlook.Items 
    Set filteredItms = itms.Restrict([FONT=Courier New]"[ReceivedTime] > '" & Mydate & "' And [ReceivedTime] < '" & Mydate + 7 & "'")[/FONT] 
    
    
    Formatting tags added by mark007
    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:

    VB:
    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 
    
    
    Formatting tags added by mark007
    Thanks Again

    Regards

    Carrotkiller

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