Shared mail Box Export to Excel with Between Specfic Date & Time Range

[AbhisshrivastAV]

hello ,

I need help for Shared outlook mail box mail export to excel using vba.

but I have some condition.
For Ex. *) I want export only inbox email with between from date & time TO Date time which I will be mentioned on Popup.


so please help me on that I have code but there only run for From Date To Date so please help me .
Code is below which I have.


Sub ImportEmail()
' Add a reference for "Microsoft Outlook nn.n Object Library"
' Toggle to display debugging info to immediate window
Const Debugging = False
Dim objNS As Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objSubFolder As Outlook.MAPIFolder
Dim objEmail As Outlook.MailItem
Dim intEmailIndex As Integer
Dim intRowIndex As Integer
Dim strMailBoxName As String
Dim strFolderName As String
Dim datFromDate
Dim datToDate As Date
Dim objSheet As Worksheet
Dim intCountExport As Integer

' Select folder to process
Set objNS = Outlook.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objNS.PickFolder
If TypeName(objFolder) = "Nothing" Then
MsgBox "No fodler selected, cancelling."
Exit Sub
End If
objFolder.Items.Sort "Received"

' Specify from and to date range
' datFromDate = #1/1/2015#
' datToDate = #2/1/2016#
datFromDate = DateValue(InputBox("Enter from date: "))
datToDate = DateValue(InputBox("Enter to date: "))

' Export into first sheet in Excel
Set objSheet = ThisWorkbook.Sheets(1)
objSheet.Activate
objSheet.Cells.ClearContents
' Add Column Headers
objSheet.Cells(1, 1) = "Sender Name"
objSheet.Cells(1, 2) = "Sender Email"
objSheet.Cells(1, 3) = "To"
objSheet.Cells(1, 4) = "Subject"
objSheet.Cells(1, 5) = "Received Time"
objSheet.Cells(1, 6) = "Folder Name"
objSheet.Cells(1, 7) = "Body"

'Application.Cursor = xlWait
'Application.ScreenUpdating = False

On Error Resume Next

' Process each email item in the selected folder
intCountExport = 0
intRowIndex = 1
For intEmailIndex = 1 To objFolder.Items.Count
If Debugging Then
Debug.Print "---------------------------------------------------------"
Debug.Print "Checking: Item[" & intEmailIndex & "], Type[" & objFolder.Items.Item(intEmailIndex).Class & "]"
End If

If TypeOf objFolder.Items.Item(intEmailIndex) Is Outlook.MailItem Then
If Debugging Then Debug.Print "Setting: Item[" & intEmailIndex & "], Type[" & objFolder.Items.Item(intEmailIndex).Class & "]"
Set objEmail = objFolder.Items.Item(intEmailIndex)
If Debugging Then Debug.Print "Selecting: Item[" & intEmailIndex & "], Type[" & objFolder.Items.Item(intEmailIndex).Class & "]"
' Only process mail in the date range we want
If objEmail.ReceivedTime >= datFromDate And objEmail.ReceivedTime <= datToDate Then
intCountExport = intCountExport + 1
If Debugging Then Debug.Print "Exporting: Item[" & intEmailIndex & "], Type[" & objFolder.Items.Item(intEmailIndex).Class & "]"
intRowIndex = intRowIndex + 1
On Error Resume Next
objSheet.Cells(intRowIndex, 1).Select
objSheet.Cells(intRowIndex, 1) = objEmail.SenderName
objSheet.Cells(intRowIndex, 2) = objEmail.SenderEmailAddress
objSheet.Cells(intRowIndex, 3) = objEmail.To
objSheet.Cells(intRowIndex, 4) = objEmail.Subject
objSheet.Cells(intRowIndex, 5) = objEmail.ReceivedTime
objSheet.Cells(intRowIndex, 6) = objFolder.Name
objSheet.Cells(intRowIndex, 7) = objEmail.Body
On Error GoTo 0
End If
Set objEmail = Nothing
Else
If Debugging Then Debug.Print "Skipped: Item[" & intEmailIndex & "], Type[" & objFolder.Items.Item(intEmailIndex).Class & "]"
End If
Next intEmailIndex

'Application.ScreenUpdating = True
'Application.Cursor = xlDefault

MsgBox intCountExport & " emails selected and exported."

End Sub