Option Explicit
Dim n As Long
Sub Launch_Pad()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Date1, Date2
Do
'Date1 = Application.InputBox("Enter a date or select the cell with the starting date", "Start Date", , , , , , 10)
Date1 = Application.InputBox("Enter a date or select the cell with the starting date", "Start Date", "=J1", , , , , 10)
If Date1 = False Then Exit Sub
On Error Resume Next
Date1 = CDate(Date1)
On Error GoTo 0
Loop Until IsDate(Date1)
Do
'Date2 = Application.InputBox("Enter a date or select the cell with the ending date", "End Date", , , , , , 10)
Date2 = Application.InputBox("Enter a date or select the cell with the ending date", "End Date", "=K1", , , , , 10)
If Date2 = False Then Exit Sub
On Error Resume Next
Date2 = CDate(Date2)
On Error GoTo 0
Loop Until IsDate(Date2)
'MsgBox Format(Date1, "dd mmm yyyy") & ", " & Format(Date2, "dd mmm yyyy")
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
n = 2
Cells.ClearContents 'if there are start/end dates in any cell on this sheet this command will erase them
Call ProcessFolder(olFolder, Date1, Date2)
Set olNS = Nothing
Set olFolder = Nothing
Set olApp = Nothing
Set olNS = Nothing
End Sub
Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, Date1, Date2)
Dim olFolder As Outlook.MAPIFolder
Dim olObject As Object
Dim olMail As Outlook.MailItem
On Error Resume Next
For Each olObject In olfdStart.Items
If TypeName(olObject) = "MailItem" Then
'Application.StatusBar = olObject.ReceivedTime
'If olObject.SentOn >= Date1 And olObject.SentOn <= Date2 Then
If olObject.ReceivedTime >= Date1 And olObject.ReceivedTime <= Date2 Then
n = n + 1
Set olMail = olObject
Cells(n, 1) = olMail.Subject
If Not olMail.UnRead Then Cells(n, 2) = "Message is read" Else Cells(n, 2) = "Message is unread"
Cells(n, 3) = olMail.ReceivedTime
Cells(n, 4) = olMail.LastModificationTime
Cells(n, 5) = olMail.Categories
Cells(n, 6) = olMail.SenderName
Cells(n, 7) = olMail.FlagRequest
Cells(n, 8) = olMail.reminderset
Cells(n, 9) = olMail.remindertime
Cells(n, 10) = olMail.reminderstatus
Cells(n, 11) = olMail.todotaskordinal
End If
End If
Next
Set olMail = Nothing
Set olFolder = Nothing
Set olObject = Nothing
End Sub
