获取未从共享邮箱 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