VBA to loop through all inboxes including shared inboxes - excel

I have working code that replies to an email in the user's Outlook, based on the subject. However I am not able to have the code search through all the user's inboxes.
As of now it will only search through the user's specific inbox. Here is my code, I have searched around but I can not find a solution that my knowledge of VBA can comprehend.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End Sub

You may reference any Inbox like this:
Option Explicit
Sub Inbox_by_Store()
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
Debug.Print j & " DisplayName - " & allStores(j).DisplayName
Set storeInbox = Nothing
' Some stores will not have an inbox
' Bypass possible expected error if there is no inbox in the store
On Error Resume Next
' Note this is one of the rare acceptable uses for On Error Resume Next
Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
' Turn off error bypass as soon as it is no longer needed
On Error GoTo 0
If Not storeInbox Is Nothing Then
storeInbox.Display
' your code here instead of storeInbox.Display
' Set Fldr = storeInbox
End If
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub

I don't really have the ability to test out whether this works, but these are the changes that I mentioned in the comments, I hope they work!
Sub Display()
'...
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Dim mySubfolder As Outlook.Folder 'added
For Each mySubfolder In Fldr.Folders 'added
Set olItems = mySubfolder.Items 'changed
For i = 1 To olItems.count
'...
Next i
Next mySubfolder 'added
End Sub

Related

Loop to auto reply to all email in a folder while looping to match a subject in Excel cells

I created the below code to reply based on the email subject listed in Excel cells. It cannot loop through the cells.
It can only reply to one email and cannot continue to the next step.
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)
IsExecuted = False
i = 2
For Each olMail In Fldr.Items
If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
With olMail.Reply
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
.Display
End With
i = i + 1
End If
Next olMail
End Sub
You change rows before checking all items.
You could move i = i + 1 after Next olMail but you would need additional code to complete the second loop.
Instead apply another For loop.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Display()
' Early binding
' Set reference to Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.Folder
Dim olMail As Object
Dim i As Long
Dim lastRow As Long
Dim Signature As String
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)
' https://stackoverflow.com/questions/38882321/better-way-to-find-last-used-row
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Debug.Print
Debug.Print "lastRow:" & lastRow
For i = 2 To lastRow
Debug.Print
Debug.Print i & "- " & ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
For Each olMail In Fldr.Items
Debug.Print " " & olMail.Subject
If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
With olMail.Reply
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
Debug.Print "*** match ***"
.Display
End With
End If
Next olMail
Next
End Sub
Outlook folders may contain different kind of items. So, when you iterate over all items in the folder you may deal with different items - appointments, documents, notes and etc. To make sure that you deal with mail items only I'd recommend checking the MessageClass property of the item before accessing item-specific properties at runtime. Otherwise, an error will be raised and your loop will never come to the end.

Run same macro in different versions of Excel / Outlook / Word

I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

Loop through all Outlook inboxes including shared inboxes error

I have code that will search through a user's Outlook and reply to an email depending on the Subject phrase you input in the worksheet cell. I did have it working a couple days ago, but now I can not seem to get it to work (was deleted). Once run, an error message will continuously display for code line "Set olitems = flrd.Items", saying "Object variable or With block variable not set". I think the problem is the End if but wherever I place it either the code does nothing or the same error displays.
The only other problem with the working code (when it worked) was that it populated more than once. I wish it to populate only one time.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
End if
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
Set Fldr = StoreInbox
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub
Firstly, get rid of the On Error Resume Next line.
Secondly, Fldr variable is never set. Did you mean to use storeInbox variable instead?
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End if
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub

Reply to a specific Outlook email using VBA with a customized Body/Subject

Sub Display()
Dim myMail As Outlook.MailItem
Dim myReply As Outlook.MailItem
Dim numItems As Integer
Dim mySelected As Selection
Dim i As Integer
Dim myText As String
Dim signature As String
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set mySelected = Outlook.ActiveExplorer.Selection
numItems = mySelected.Count
For i = 1 To numItems
Set myMail = mySelected(1)
Set myReply = myMail.Reply
myText = myMail.Body
myReply.Subject = "RO Finalized WF: Annual Review. Entity"
myText = "Hi All," & vbCrLf & vbCrLf & "Worflow ID:" & vbCrLf & vbCrLf & "infoinfoinfoinfo" & vbCrLf & vbCrLf & "Thanks," & vbCrLf & "Josh" & signature
myReply.HTMLBody = myText & vbCrLf & vbCrLf & myMail.HTMLBody
Myreply.display
Set myMail = Nothing
Set myReply = Nothing
Next
Set mySelected = Nothing
End Sub
The code above displays a reply to the email you currently have open in Outlook including who sent it (placed in To:) with the whole body of the email you currently have open in Outlook.
This is what I want it to do except instead of replying to the open email, I want it to reply to the email specifically by it's subject. Also I want it to include exactly what all replies include in Outlook (the line separating each email, with the From:, Sent,: To:, CC:, Subject: of the previous email showing). Also vbCrLf is not doing it's purpose after MyText.
I would also like it to place the CC: from the previous email in the CC of the email I am creating.
I am not an expert in VBA and have tried as much as I could think of.
Thank you for the help in advance :)
I have found another option and the code is displayed below.
This will populate a reply email, with everything I need except my customized body.
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "checklist") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "Dear All," & "<br>" & signature
End With
IsExecuted = True
olmail.ReplyAll.Display
End If
End If
Next olMail
End Sub
Solution
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "Subject") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & signature & .HTMLBody
.Display
End With
IsExecuted = True
End If
End If
Next olMail
End Sub

Replying to an Outlook mail based on subject, received time and date

I will receive the Journal entries from the client and need to reply to the same mail.
I have tried the below code to execute reply to chain of mails. But the code is returning the all mails which contains the same subject line.
I need to reply which comes recently. I have tried many solutions, but I unable to fix it.
How do I Reply to an email based on subject, received time and date
Sub mail()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
For Each olMail In olFldr.Items
If InStr(olMail.Subject, Range("C2")) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica <br><br>" & _
"The " & _
Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) & "</B> has been posted.<br>" & _
"<br><br>Regards," & _
"<br><br>Rajesh</font>" & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
End Sub
Work with Items.Restrict Method (Outlook) to Filter by Subject and Date & Time
Make sure to convert your subject Range("C2") to string variable then use it on your filter
Example
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("Sheet1").Range("C2").Text
Debug.Print Subject
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/20/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/25/2018' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is mailitem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
End If
Next
End Sub
Items.Restrict Method Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.
Edit - Complete Code
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("Sheet1").Range("C2").Text
Debug.Print Subject
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '03/07/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '03/25/2018' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica <br><br>" & _
"The " & Left(ActiveWorkbook.name, _
InStr(ActiveWorkbook.name, ".") - 1) & _
"</B> has been posted.<br>" & _
"<br><br>Regards," & _
"<br><br>Rajesh</font>" & .HTMLBody
.Display
End With
End If
Next
End Sub
https://stackoverflow.com/a/43622710/4539709

Resources