如何在 AdvancedSearch 中应用 DASL 过滤器？

Question

我修改了代码，以便回复最新的电子邮件。

我遍历电子表格中的一系列单元格以获取一个字符串以在我的收件箱中查找电子邮件或发送的项目。

代码有时会找到并打开电子邮件线程，有时却不会。

我的过滤器的语法是否正确？

searchString = "urn:schemas:httpmail:textdescription ci_phrasematch" & supNumber

我注释了这些行，否则它不会停止循环：

While searchComplete = False
'        DoEvents
Wend

事件处理程序OutlookApp_AdvancedSearchComplete 永远不会触发

以下代码保存在类模块中：

Option Explicit

' Credits: Based on this answer: https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba

' Event handler for outlook
Dim WithEvents OutlookApp As Outlook.Application
Dim outlookSearch As Outlook.Search
Dim outlookResults As Outlook.Results

Dim searchComplete As Boolean
Private Declare Function GetTickCount Lib "Kernel32" () As Long


Sub Minuterie(Milliseconde As Long)
    Dim Arret As Long
    Arret = GetTickCount() + Milliseconde
    Do While GetTickCount() < Arret
        DoEvents
    Loop
End Sub


' Handler for Advanced search complete
Private Sub OutlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
    MsgBox "The AdvancedSearchComplete Event fired."
    searchComplete = True
End Sub


Sub SearchAndReply(program_number As Range, searchFolderName As String, searchSubFolders As Boolean)

    ' Declare objects variables
    Dim customMailItem As Outlook.MailItem
    Dim searchString As String
    Dim resultItem As Integer
    Dim supNumber As String
    Dim compName As String
    Dim strFilter As String
    Dim OutlookApp As Outlook.Application
    Dim strTag As String
    Dim answer As VbMsgBoxResult
    ' Variable defined at the class level
    'Dim outlookSearch As Outlook.Search
    Set OutlookApp = New Outlook.Application
    
    strTag = "BodySearch"
    
    ' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
    searchComplete = False
     
    supNumber = "'" & program_number.Value & "'"
    searchString = "urn:schemas:httpmail:textdescription ci_phrasematch" & supNumber
    
    ' Perform advanced search
    Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName, searchString, searchSubFolders)
        Minuterie 2000
    ' Wait until search is complete based on outlookApp_AdvancedSearchComplete event
'    While searchComplete = False
'        DoEvents
'    Wend

    ' Get the results
    Set outlookResults = outlookSearch.Results

    If outlookResults.Count = 0 Then
        program_number.Interior.Color = vbRed
        Exit Sub
    End If

    ' Sort descending so you get the latest
    outlookResults.Sort "[SentOn]", True

    ' Reply only to the latest one
    resultItem = 1

    ' Some properties you can check from the email item for debugging purposes
    On Error Resume Next
    Debug.Print outlookResults.Item(resultItem).SentOn, outlookResults.Item(resultItem).ReceivedTime, outlookResults.Item(resultItem).SenderName, outlookResults.Item(resultItem).subject
    On Error GoTo 0

    Set customMailItem = outlookResults.Item(resultItem).ReplyAll

    ' At least one reply setting is required in order to replyall to fire
    'customMailItem.Body = "Just a reply text " & customMailItem.Body
    customMailItem.HTMLBody = "<p> Thank you <p>" & customMailItem.HTMLBody

    customMailItem.Display
    program_number.Interior.Color = vbYellow
                         
End Sub

我在 Excel 的常规模块中保存了以下代码：

Public Sub ProcessEmails()

    Dim testOutlook As Object
    Dim oOutlook As clsOutlook
    Dim searchRange As Range
    Dim subjectCell As Range
    Dim OGDD_Programs As Range
    Dim searchFolderName As String
    Dim answer As VbMsgBoxResult
    Dim Sup_ENg_Number As Range

    ' Start outlook if it isn't opened (credits: https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba)
    On Error Resume Next
    Set testOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If testOutlook Is Nothing Then
        Shell ("OUTLOOK")
    End If

    ' Initialize Outlook class
    Set oOutlook = New clsOutlook

    ' Get the outlook inbox and sent items folders path (check the scope specification here: https://docs.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch)
    searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
'
'    ' Loop through excel cells with subjects
'    Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A2:A4")
    'set a reference to cells we are going to loop through
    Set OGDD_Programs = ActiveSheet.Range("A2", "A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)

    For Each Sup_ENg_Number In OGDD_Programs
      If (Sup_ENg_Number.Interior.Color = vbYellow Or Sup_ENg_Number.Interior.Color = vbRed) Then
      
        Else

            ' Only to cells with actual subjects
            If Sup_ENg_Number.Value <> vbNullString Then
        
                Call oOutlook.SearchAndReply(Sup_ENg_Number, searchFolderName, True)        
                answer = MsgBox("Do you want to exit subRoutine ?", vbYesNo)
                            
                If answer = vbYes Then
                    Exit Sub
                End If

            End If
        End If
      
    Next Sup_ENg_Number

    MsgBox "Search and reply completed"

    ' Clean object
    Set testOutlook = Nothing

End Sub

'Then add a class module and name it: clsOutlook

Answer 1

为什么需要AdvancedSearch（这是异步的）？使用MAPIFolder.Items.Find。 （其中MAPIFolder是你需要搜索的文件夹，比如使用Application.Session.GetDEfaultFolder(olFolderInbox)检索到的收件箱）。

Answer 2

代码应首先检查默认存储中是否启用了Instant Search，以确定是使用ci_phrasematch关键字来精确匹配项目正文中的“关键字”，还是使用like关键字来匹配任何出现的“关键字”作为项目正文中的确切字符串或子字符串。例如：

 Dim filter As String
    If (Application.Session.DefaultStore.IsInstantSearchEnabled) Then
        filter = "@SQL=" & Chr(34) _
            & "urn:schemas:httpmail:textdescription" & Chr(34) _
            & " ci_phrasematch 'office'"
    Else
        filter = "@SQL=" & Chr(34) _
            & "urn:schemas:httpmail:textdescription" & Chr(34) _
            & " like '%office%'"
    End If

在 Outlook 中使用 AdvancedSearch 方法的主要好处是：

• 搜索在另一个线程中执行。您无需手动运行另一个线程，因为 AdvancedSearch 方法会在后台自动运行它。
• 可以在任何位置（即超出某个文件夹的范围）搜索任何项目类型：邮件、约会、日历、便笺等。 Restrict 和Find/FindNext 方法可以应用于特定的Items 集合（请参阅Outlook 中Folder 类的Items 属性）。
• 完全支持 DASL 查询（自定义属性也可用于搜索）。您可以在 MSDN 中的 Filtering 文章中阅读有关此内容的更多信息。为了提高搜索性能，如果为商店启用了即时搜索，则可以使用Instant Search 关键字（请参阅Store 类的IsInstantSearchEnabled 属性）。
• 您可以随时使用 Search 类的 Stop 方法停止搜索过程。

在Advanced search in Outlook programmatically: C#, VB.NET 文章中了解更多信息。

Answer 3

Re：事件处理程序 OutlookApp_AdvancedSearchComplete 永远不会触发。

我必须解决这个问题。

Option Explicit

Private Sub Get_LastMail_AdvSearch_URN_Subject()
    
    Dim strSearch As String
    Dim strFilter As String
    
    Dim strScope As String
    
    Dim objSearch As Search
    
    Dim fldrNm As String
    
    Dim rsts As results
    Dim rstObj As Object
    
    Debug.Print
    
     strScope = "'Inbox', 'Sent Items', 'Deleted Items'"
    'strScope = "'Inbox', 'Sent Items'"
    Debug.Print "strScope............: " & strScope
    
    strSearch = "test"
    fldrNm = "Subject: " & strSearch
    Debug.Print fldrNm
    
    strFilter = "urn:schemas:httpmail:subject LIKE '%" & strSearch & "%'"
    Debug.Print strFilter

    Set objSearch = AdvancedSearch(scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="SearchFolder")
    
    ' The Application.AdvancedSearchComplete event is problem
    '  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
    
    ' Saving may be enough. This would be ideal but not on my machine.
    ' You may have to delete a previously generated search folder before subsequent runs
    objSearch.Save fldrNm
    DoEvents
    Debug.Print fldrNm & " saved."
    
    Set rsts = objSearch.results
    Debug.Print " rsts.Count: " & rsts.Count
    
    If rsts.Count = 0 Then
    
        Debug.Print "Delay initiated."
        
        ' Delay to allow the search to complete
        Dim waitTime As Long
        Dim delay As Date
        
        ' Will surely be too little at the most inopportune time
        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
    End If
    
    Set rsts = objSearch.results
    Debug.Print " rsts.Count: " & rsts.Count
    
    If rsts.Count > 0 Then
        rsts.Sort "[ReceivedTime]", True
        Set rstObj = rsts(1)
        Debug.Print rstObj.subject
    
    Else
        Debug.Print "no items found."
        
    End If

End Sub