獲取未從共享郵箱 VBA 回復的電子郵件

Question

我正在嘗試從我不是所有者的共享郵箱中提取電子郵件，我有權代表我發送但無法保存搜索，如果有人可以在過去 24 小時內協助獲取未從共享郵箱回復的電子郵件，下面是我的代碼能夠做到

    

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

請建議解決方案

Answer 1

沒有理由使用（異步） AdvancedSearch （除非您希望將列表保存為搜索文件夾）； 使用（同步） 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

這演示了在沒有搜索文件夾的情況下處理搜索結果。

在一個尤里卡時刻之后。

Option Explicit

' Code in ThisOutlookSession

Public blnSearchComp As Boolean

Private Sub Application_AdvancedSearchComplete(ByVal objSearch As Search)
' https://docs.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://docs.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

如果 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://docs.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