Option Explicit
Sub MoveAndEmailReport()
Dim olApp As Object
Dim olNS As Object
Dim olInBox As Object
Dim olFolderDaily1 As Object
Dim olFolderDaily2 As Object
Dim olItem As Object
Dim olMail As Object
Dim strSearchForSubject1 As String
Dim strSearchForSubject2 As String
Dim strHtmlContents As String
Dim strHtmlBody As String
Dim blnStarted As Boolean
Dim blnMoved 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
'Set first personal folder
Set olFolderDaily1 = olNS.Folders("Daily email1")
'Set second personal folder
Set olFolderDaily2 = olNS.Folders("Daily email2")
strSearchForSubject1 = "MySubject1" 'change first subject to search for
strSearchForSubject2 = "MySubject2" 'change second subject to search for
'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 = olInBox.items.Count To 1 Step -1
Set olItem = olInBox.items(itemIndex)
If TypeName(olItem) = "MailItem" Then
If InStr(1, olItem.Subject, strSearchForSubject1, vbTextCompare) > 0 Then
olItem.Move olFolderDaily1
blnMoved = True
ElseIf InStr(1, olItem.Subject, strSearchForSubject2, vbTextCompare) Then
olItem.Move olFolderDaily2
blnMoved = True
End If
If blnMoved Then
strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.receivedtime & "</td>"
strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
emailCount = emailCount + 1
blnMoved = False
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 olFolderDaily1 = Nothing
Set olFolderDaily2 = Nothing
Set olItem = Nothing
Set olMail = Nothing
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
Resume exitHandler
End Sub
