How to derive date of sent item in Excel VBA

[ThrottleWorks]

Hi,

I am using below code to get details of e-mail of a specified folder.
I need to get details for last 5 working days only.

How do I do this. Can anyone please help me in this.
Current loop works on each e-mail from the folder.

I need to get details of e-mails which has received date within last working 5 days.
And should skip rest of e-mails.

For example,
? myDraftsFolder.Items.Item(lDraftItem).ReceivedTime
05/08/2015 20:47:37

And
? Date
27/03/2018
How do I derive 05/08/2015 from ReceivedTime and check if date is within last 5 working days from today.

How to convert 'myDraftsFolder.Items.Item(lDraftItem).ReceivedTime' in date and reconcile it with last 5 working days from today.

Option Explicit

Sub Get_Outlook_Extract()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Dim lDraftItem As Long
    Dim myOutlook As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolders As Outlook.Folders
    Dim myDraftsFolder As Outlook.MAPIFolder
 
    Set myOutlook = Outlook.Application
    Set myNameSpace = myOutlook.GetNamespace("MAPI")
    Set myFolders = myNameSpace.Folders
 
    Dim MacroSht As Worksheet
    Set MacroSht = Worksheets("Main")
     
    Dim UserSht As Worksheet
    Set UserSht = ThisWorkbook.Worksheets("User Profile")
 
    Set myDraftsFolder = myFolders(UserSht.Range("C2").Value).Folders(UserSht.Range("D2").Value)
 
    Dim wks As Worksheet
    Dim intColumnCounter As Long
    Dim TempLr As Long
    Dim itm As Object
    Dim rng As Range
 
    Set wks = ThisWorkbook.Worksheets("Outlook Data")
    wks.Select
    wks.Cells.Clear
 
    Application.StatusBar = ""
    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
        On Error Resume Next
            Application.StatusBar = myDraftsFolder.Items.Item(lDraftItem).SentOn
            If myDraftsFolder.Items.Item(lDraftItem).ReceivedTime= Date Then
                intColumnCounter = 1
             
                TempLr = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row + 1
                Set msg = itm
             
                'A To
                Set rng = wks.Cells(TempLr, 1)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).To
                'B Sender
                Set rng = wks.Cells(TempLr, 2)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).SenderName
                'C Subkect
                Set rng = wks.Cells(TempLr, 3)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).Subject
                'D Date
                Set rng = wks.Cells(TempLr, 4)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).SentOn
                'E Category
                Set rng = wks.Cells(TempLr, 5)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).Categories
                'F CC
                Set rng = wks.Cells(TempLr, 6)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).CC
                'G ConversationID
                Set rng = wks.Cells(TempLr, 7)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).ConversationID
                'H CreationTime
                Set rng = wks.Cells(TempLr, 8)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).CreationTime
                'I Entry ID
                Set rng = wks.Cells(TempLr, 9)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).EntryID
                'J Last modified time
                Set rng = wks.Cells(TempLr, 10)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).LastModificationTime
                'K Folder Name
                Set rng = wks.Cells(TempLr, 11)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).Parent
                'L Sent of behalf
                Set rng = wks.Cells(TempLr, 12)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).SentOnBehalfOfName
                'M Account
                Set rng = wks.Cells(TempLr, 13)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).SendUsingAccount
                'N Body
    '''            Set rng = wks.Cells(TempLr, 14)
    '''            rng.Value = myDraftsFolder.Items.Item(lDraftItem).Body
             
                'O Original Subject line
                Set rng = wks.Cells(TempLr, 15)
                rng.Value = myDraftsFolder.Items.Item(lDraftItem).ConversationTopic
            End If
        On Error GoTo 0
    Next lDraftItem
     
    wks.Range("A1") = "To"
    wks.Range("B1") = "Sender"
    wks.Range("C1") = "Subject"
    wks.Range("D1") = "Date"
    wks.Range("E1") = "Category"
    wks.Range("F1") = "CC"
    wks.Range("G1") = "Conversation ID"
    wks.Range("H1") = "Creation Time"
    wks.Range("I1") = "Entry ID"
    wks.Range("J1") = "Last Modified time"
    wks.Range("K1") = "Folder Name"
    wks.Range("L1") = "Sent on behalf"
    wks.Range("M1") = "Account"
    wks.Range("N1") = "E-Mail"
    wks.Range("O1") = "Original Subject Line"
     
    wks.Cells.Font.Size = 9
    wks.Cells.Font.Name = "Calibri"
    wks.Cells.WrapText = False
     
    'Clean-up
    Set myDraftsFolder = Nothing
    Set myNameSpace = Nothing
    Set myOutlook = Nothing
    MsgBox "Done !"
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[Debaser]

You could use:

If myDraftsFolder.Items.Item(lDraftItem).ReceivedTime >= application.worksheetfunction.WorkDay(date, -5))

 

[ThrottleWorks]

Hi @Debaser thanks a lot for the help. It is working fine.

Could you please help in below if you get time.
How can I make my loop fast.
The current code takes more that 4 minutes to get complete.
There are around 3,000 items in the folder.

Have a nice day ahead.

 

[Debaser]

You can filter the folder like this:

Set restrictedItems = myDraftsFolder.items.Restrict("[ReceivedTime] > '" & Format(application.worksheetfunction.WorkDay(date, -5)), "yyyy/mm/dd") & "'")

and then just loop through the restrictedItems collection.

 

[ThrottleWorks]

Hi @Debaser sorry to bother you again.
While pasting this line, I am getting below error message.

Expected: End of Statement.

Could you please help if you get time.

 

[Debaser]

Sorry - lazy copy and paste:

Set restrictedItems = myDraftsFolder.items.Restrict("[ReceivedTime] > '" & Format(application.worksheetfunction.WorkDay(date, -5), "yyyy/mm/dd") & "'")

 

[ThrottleWorks]

Hi @Debaser thanks a lot for the help. Have a nice day ahead.