Option Explicit
Public Sub ListMails()
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 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 = GetMailsByDate(objOlApp, objFld, dteDate)
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
Public Function GetMailsByDate(ByVal OlApp As Outlook.Application, ByVal Fld As Outlook.Folder, ByVal DateVal As Date) 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 = "@SQL=" & Quote("urn:schemas:httpmail:datereceived") & " >= " & SingleQuote(dteDate)
Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
Const PR_SUBJECT As String = "http://schemas.microsoft.com/mapi/proptag/0x0037001F"
Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
Dim objTbl As Outlook.Table, colResults As Collection, objResult As MailInfo, objRow As Outlook.Row, colAttachmentNames As Collection, objAtt As Outlook.Attachment
Set colResults = New Collection
Set objTbl = Fld.GetTable(strFilter)
With objTbl
.Columns.RemoveAll
.Columns.Add "EntryId"
.Columns.Add PR_SENDER_EMAIL_ADDRESS
.Columns.Add PR_SUBJECT
.Columns.Add PR_HASATTACH
.Columns.Add "urn:schemas:httpmail:datereceived"
Do Until .EndOfTable
Set objResult = New MailInfo
Set objRow = .GetNextRow
With objResult
.HasAttachments = objRow(4)
.Subject = objRow(3)
.SenderEmailAddress = objRow(2)
.ReceivedTime = objRow.UTCToLocalTime(5)
If .HasAttachments Then
Set colAttachmentNames = New Collection
Set objMail = OlApp.Session.GetItemFromID(objRow(1))
For Each objAtt In objMail.Attachments
colAttachmentNames.Add objAtt.Filename
Next
objMail.Close olDiscard
Set .Attachments = colAttachmentNames
End If
.EntryId = objRow(1)
End With
colResults.Add objResult
Loop
End With
Set GetMailsByDate = 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
