Have VBA loop through all inboxes in Outlook including shared inboxes - excel

Question

My goal with this code is to reply to a specific email in the user's outlook depending on the subject(B8). Essentially have the code loop through all the user's inboxes including shared inboxes to find the email.
The first code I have will go into the user's outlook but only their main inbox and pull the email to reply to. This works without error.
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 Long
Dim signature As String
Dim olitem As Object
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Set olitems = Fldr.Items
olitems.Sort "[Received]", True
For i = 1 To olitems.Count
Set olitem = olitems(i)
If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
Set olMail = olitem
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," & "Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject
End With
Exit For
olMail.Categories = "Executed"
Exit For
End If
End If
SkipToNext:
Next i
End Sub
This second section of code is my trial and error as well as the use of other resources attempt to have the code loop through all the inboxes of the user. The thing is it doesn't do anything anymore.
I did have working code for this scenario, then I mistakenly saved over it and I have not been successful in getting it back working. Below is as close as I have been able to get.
Any suggestions would be greatly appreciated.
The second script seems to be skipping from "Set olitems = Fldr.Items" to the bottom End If.
I thought maybe to move the End if right below "If not storeinbox Is Nothing Then" but the error "Object variable or With block variable not set" occurs.
When I do change the code line (While making the change above also) "Set Fldr = Storeinbox" to "Set Fldr = Session.GetDefaultFolder(olFolderInbox)" emails will populate, but only in the user's specific inbox(Does not pick up subject text, just most recent email).
I have added additional code to the second script
Set olitem = olitems(i)
If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
Set olMail = olitem
Which was missing. This will populate the email for the user's specific email address by the subject. If I type in a subject from another inbox then nothing will happen but it will go through the code with no errors.
Getting closer, but still nothing for the shared inboxes.
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 j & " DisplayName - " & allStores(j).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
Set Fldr = storeinbox
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.Count
Set olitem = olitems(i)
If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
Set olMail = olitem
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," &
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next
End If
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
SkipToNext:
Next j
End Sub

Answer 1

If you Set allStores = Nothing inside the j loop it will only be something in the first iteration.
Option Explicit
' Think of Option Explicit as being mandatory
' Tools | Options
' Editor tab
' Checkbox "Require Variable Declaration"
' Option Explict will generate automatically on new modules
' You may type it in at the top of an existing module
' This as well points out possible spelling errors in the variables
Sub Display()
'In Excel set reference to Outlook Object Library
Dim Fldr As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim olItem As Object
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim signature As String
Dim i As Long
Dim j As Long
Dim allStores As Stores
Dim storeInbox As Folder
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Else
signature = ""
End If
' Usually works with Outlook open.
' If this proves to be unreliable,
' you may need a CreateObject("Outlook.Application")
Set allStores = Session.Stores
For j = 1 To allStores.Count
' No need to bypass wrong index error here
' The error has been fixed by using j not i
Debug.Print j & " DisplayName - " & allStores(j).DisplayName
' Reset storeInbox to nothing or it will remain the previous
' when there is an error on the current store
' This is one example of why to be careful with On Error Resume Next
Set storeInbox = Nothing
On Error Resume Next
' bypass error if store does not have an inbox
Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
Set Fldr = storeInbox
Set olItems = Fldr.Items
' Not needed?
'olItems.Sort "[Received]", True
For i = 1 To olItems.Count
Set olItem = olItems(i)
If TypeOf olItem Is Outlook.MailItem Then
Set olMail = olItem
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," & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
' Generates a compile error. Appears not needed.
'.Subject
End With
olMail.Categories = "Executed"
olMail.Display 'olMail.Save
End If
End If
End If
Next
End If
Next j
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub