Option Explicit
Public SearchComplete As Boolean
Public Sub ListMails()
SearchComplete = False
Dim objSh As Excel.Worksheet
On Error Resume Next
Set objSh = Sheet1
If Err.Number <> 0 Then
Call MsgBox("The required worksheet 'Sheet1' was not found.", vbExclamation, "Error: Worksheet Not Found")
Exit Sub
End If
On Error GoTo 0
Dim dblTimeOut As Double
dblTimeOut = objSh.Range("C3").Value2
If dblTimeOut <= 0 Then
Call MsgBox("Invalid timeout", vbExclamation, "Error")
Exit Sub
End If
Dim objOlApp As Outlook.Application
On Error Resume Next
Set objOlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Call MsgBox("This macro requires a running instance of Outlook. Please try again later!", vbExclamation, "Error: Outlook Not Running")
Exit Sub
End If
On Error GoTo 0
Dim objFld As Outlook.Folder
Set objFld = objOlApp.Session.PickFolder
If objFld Is Nothing Then
Call MsgBox("Please select a folder to continue", vbExclamation, "Error: Folder Not Specified")
Exit Sub
End If
objSh.Range("C1").Value2 = objFld.FolderPath
Dim dteDate As Date
dteDate = CDate(objSh.Range("C2").Value2)
Dim colItems As Collection
Set colItems = GetMailsByDateUsingAdvancedSearch(objOlApp, objFld, dteDate, dblTimeOut)
If colItems.Count = 0 Then
Call MsgBox("No mail item was found that matched the criteria 'after " & CStr(dteDate) & "'", vbInformation, "Search Result")
Exit Sub
End If
Dim lngLastRow As Long, lngRowsCount As Long
lngRowsCount = objSh.Rows.Count
lngLastRow = objSh.Cells(lngRowsCount, 1).End(xlUp).Row
If lngLastRow > 5 Then objSh.Range("A5:G" & CStr(lngLastRow)).ClearContents
Dim arrResult As Variant, i As Long, j As Long, objResult As MailInfo, strAttFileNames As String
ReDim arrResult(1 To colItems.Count, 1 To 7) As Variant
For i = 1 To colItems.Count
arrResult(i, 1) = i
Set objResult = colItems.Item(i)
arrResult(i, 2) = objResult.SenderEmailAddress
arrResult(i, 3) = objResult.Subject
If objResult.HasAttachments Then
For j = 1 To objResult.Attachments.Count
If j = objResult.Attachments.Count Then
strAttFileNames = strAttFileNames & objResult.Attachments.Item(j)
Else: strAttFileNames = strAttFileNames & objResult.Attachments.Item(j) & ", "
End If
Next
arrResult(i, 4) = strAttFileNames
End If
arrResult(i, 5) = objResult.EntryId
arrResult(i, 6) = objResult.ReceivedTime
Next
objSh.Range("A5").Resize(UBound(arrResult), UBound(arrResult, 2)).Value2 = arrResult
lngLastRow = objSh.Cells(lngRowsCount, 1).End(xlUp).Row
Dim objCell As Excel.Range, objLinkRange As Excel.Range
Set objLinkRange = objSh.Range("E5:E" & CStr(lngLastRow))
For Each objCell In objLinkRange
objSh.Hyperlinks.Add objCell, "", objCell.Value2, "Open Mail", "Click here to open mail from Outlook"
Next
End Sub
Private Function GetMailsByDateUsingAdvancedSearch(ByVal OlApp As Outlook.Application, ByVal Fld As Outlook.Folder, ByVal DateVal As Date, ByVal TimeOut As Double) As Collection
If OlApp Is Nothing Or Fld Is Nothing Then Exit Function
Dim objMail As Outlook.MailItem
Dim dteDate As Date, objPA As Outlook.PropertyAccessor
Set objMail = OlApp.CreateItem(olMailItem)
Set objPA = objMail.PropertyAccessor
dteDate = objPA.LocalTimeToUTC(DateVal)
objMail.Close olDiscard
Dim strFilter As String
strFilter = Quote("urn:schemas:httpmail:datereceived") & " >= " & SingleQuote(dteDate)
Dim objSearch As Outlook.Search, colResults As Collection
Set colResults = New Collection
Set objSearch = OlApp.AdvancedSearch(SingleQuote(Fld.FolderPath), strFilter, True, "SearchAllMailItems")
Dim dteCurrentTime As Date, dteStartTime As Date
dteStartTime = Now
While SearchComplete = False
DoEvents
dteCurrentTime = Now
If DateDiff("s", dteStartTime, dteCurrentTime, vbMonday, vbFirstJan1) >= TimeOut Then
Set GetMailsByDateUsingAdvancedSearch = colResults
Exit Function
End If
Wend
Dim objAtt As Outlook.Attachment, objMailInfo As MailInfo, objItem As Object, i As Long
Dim objResults As Outlook.Results
Set objResults = objSearch.Results
If objResults.Count > 0 Then
For i = 1 To objResults.Count
Set objItem = objResults.Item(i)
If TypeOf objItem Is Outlook.MailItem Then
Set objMail = objItem
Set objMailInfo = New MailInfo
With objMailInfo
.Subject = objMail.Subject
.SenderEmailAddress = objMail.SenderEmailAddress
.ReceivedTime = objMail.ReceivedTime
If objMail.Attachments.Count > 0 Then
.HasAttachments = True
For Each objAtt In objMail.Attachments
.Attachments.Add objAtt.Filename
Next
End If
.EntryId = objMail.EntryId
objMail.Close olDiscard
End With
colResults.Add objMailInfo
End If
Next
End If
Set GetMailsByDateUsingAdvancedSearch = colResults
End Function
Private Function Quote(ByVal Text As String) As String
Quote = Chr(34) & Text & Chr(34)
End Function
Private Function SingleQuote(ByVal Text As String) As String
SingleQuote = Chr(39) & Text & Chr(39)
End Function
