Get Emails Not Replied from Shared mailbox VBA - excel

Question

I am trying to Extract Emails from Shared mailbox which i am not Owner i have access to send on behalf
but Unable to save search and If any one can assist to Get Email in last 24hours Which are not Replied from Shared Mailbox
Below is Code Which I was Able to do it
Sub CreateSearchFolder_AllNotRepliedEmails()
Dim OutlookApp As Outlook.Application
Dim strScope As String
Dim OutlookNamespace As NameSpace
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Outlook.Search
Dim objOwner As Outlook.Recipient
Dim Folder As MAPIFolder
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
'If objOwner.Resolved Then
'Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox).FolderPath & "'"
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Set objSearch = Outlook.Application.AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True)
'Save the search folder
objSearch.Save ("Sd email not Replied")// Tried This But Not working
MsgBox "Search folder is created successfully!", vbInformation + vbOKOnly, "Search Folder"
End Sub
Kindly advise for Solution

Answer 1

There is no reason to use (asynchronous) AdvancedSearch (unless you want the list saved as a search folder); use (synchronous) Items.Restrict:
filter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
set folder = Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
set notRepliedOrForwardedItems = folder.Items.Restrict(filter)

Answer 2

This demonstrates processing search results without a search folder.
After a Eureka moment.
Option Explicit
' Code in ThisOutlookSession
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal objSearch As Search)
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch
' Code should be in a class module such as ThisOutlookSession
Debug.Print "The AdvancedSearchComplete Event fired"
If objSearch.Tag = "AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701" Then
'm_SearchComplete = True` ' Use Option Explicit.
blnSearchComp = True
End If
End Sub
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701()
' Code in ThisOutlookSession
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & _
"AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Fewer results than above.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True, _
Tag:="AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701")
' 2022-07-01 Eureka!
blnSearchComp = False
' Otherwise remains True.
' Search would work once until Outlook restarted.
While blnSearchComp = False
DoEvents
'Code should be in a class module such as ThisOutlookSession
Debug.Print "Wait a few seconds. Ctrl + Break if needed."
Wend
Debug.Print "objSearch.results.count: " & objSearch.results.count
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' Errors in the sample code:
' Typo blnSearchComp = True - use Option Explicit
' Syntax error Set sch = Application.AdvancedSearch(strS, strF, , "Test") - Missing comma
' Before each search: blnSearchComp = False - Else permanently True after first run
'
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
Else
Debug.Print "No items found."
End If
Debug.Print "Done."
End Sub
Leaving this in case there are even more pitfalls in AdvancedSearch.
Option Explicit
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder()
' Code in Outlook
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" _
& Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Deleted question indicates other options
' https://stackoverflow.com/questions/19381504/determine-whether-mail-has-been-replied-to
' 102 "Reply to Sender"
' 103 "Reply to All"
' 104 "Forward"
' 108 "Reply to Forward"
' Fewer results than above. NULL may be correct.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True)
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
'
' I have to use a workaround for AdvancedSearchComplete.
' I delay to allow the search to complete.
' Resist using this workaround in production code.
'Debug.Print "rsts.count: " & rsts.count
If rsts.count = 0 Then
Dim waitTime As Long
Dim delay As Date
moreDelay:
Debug.Print " Delay invoked."
waitTime = 1 ' in seconds - adjust as needed
Debug.Print vbCr & "Wait start: " & Now
delay = DateAdd("s", waitTime, Now)
Debug.Print "Wait until: " & delay
Do Until Now > delay
DoEvents
Loop
'Debug.Print "rsts.Count: " & rsts.count
If rsts.count = 0 Then
Debug.Print "No mail found or delay too short."
If MsgBox("No mail found or delay too short. Allow more time?", vbYesNo) = vbYes Then
GoTo moreDelay
Else
Debug.Print "No items found. / Search failure acknowledged."
End If
Else
Debug.Print " Delay successful."
GoTo processItems
End If
Else
Debug.Print "Delay not required."
GoTo processItems
End If
Debug.Print "Done."
Exit Sub
processItems:
' ---> After search is confirmed complete with AdvancedSearchComplete <---
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
End If
Debug.Print "Done."
End Sub