Sub MoveAndEmailReport()
Dim olApp As Object
Dim olNS As Object
Dim olInBox As Object
Dim olRestrictedItems As Object
Dim strFilter1 As String
Dim strFilter2 As String
Dim olMoveToFolder As Object
Dim olItem As Object
Dim olMail As Object
Dim strHtmlContents As String
Dim strHtmlBody As String
Dim blnStarted As Boolean
Dim emailCount As Long
Dim itemIndex As Long
On Error Resume Next
'Get Outlook, if its already running
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
'Outlook wasn't already running, so start it
Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then
MsgBox "Unable to open Outlook!", vbExclamation
Exit Sub
End If
blnStarted = True
End If
On Error GoTo errHandler
'Set namespace
Set olNS = olApp.GetNamespace("MAPI")
'Set inbox
Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
'Filter items for date specified in cell A1 in Sheet1 (change the sheet reference accordingly)
strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
Set olRestrictedItems = olInBox.Items.Restrict(strFilter1 & " And " & strFilter2)
'Set folder to move emails to
Set olMoveToFolder = olNS.Folders("DailyMail").Folders("Daily Mailers")
'Loop through each item in inbox, move items that meet the criteria to their
'respective folder, collect relevant data in html table format, and keep track of
'number of emails that met criteria and were moved
strHtmlContents = ""
emailCount = 0
For itemIndex = olRestrictedItems.Count To 1 Step -1
Set olItem = olRestrictedItems(itemIndex)
If TypeName(olItem) = "MailItem" Then
If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
If UCase(Left(olItem.Subject, 3)) <> "RE:" And UCase(Left(olItem.Subject, 3)) <> "FW:" Then
strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.ReceivedTime & "</td>"
strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
olItem.Move olMoveToFolder
emailCount = emailCount + 1
End If
End If
End If
Next itemIndex
'If one or more emails met the criteria and were moved, add the necessary html code
'to complete the formatting for the html table, and then create a new email with the data
'collected and send it to the specified user
If emailCount > 0 Then
strHtmlBody = "<table width=100% border=1 cellpadding=3>"
strHtmlBody = strHtmlBody & "<tr>"
strHtmlBody = strHtmlBody & vbCrLf & "<th width=70% align=left>Subject</th>"
strHtmlBody = strHtmlBody & vbCrLf & "<th align=left>Received Time</th>"
strHtmlBody = strHtmlBody & vbCrLf & "</tr>"
strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
strHtmlBody = strHtmlBody & vbCrLf & "</table>"
Set olMail = olApp.CreateItem(0)
With olMail
.To = "johnsmith@example.com" 'change the email address accordingly
.Subject = "List of emails received" 'change the subject accordingly
.htmlbody = "<p>Number of emails received: " & emailCount & "</p>"
.htmlbody = .htmlbody & strHtmlBody
.display 'to display email instead of sending it
'.send 'to send email instead of displaying it
End With
MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
Else
MsgBox "No emails received.", vbInformation
End If
exitHandler:
'If Outlook was started, close it
'Uncomment next 3 lines when emails are actual being sent
'If blnStarted Then
'olApp.Quit
'End If
Set olApp = Nothing
Set olNS = Nothing
Set olInBox = Nothing
Set olRestrictedItems = Nothing
Set olMoveToFolder = Nothing
Set olItem = Nothing
Set olMail = Nothing
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
Resume exitHandler
End Sub
