Outlook 限制方法未在收件箱和/或已发送框中找到某些项目

Question

您好，我有一个脚本可以循环遍历 Excel 表，以检查我是否收到了对已发送电子邮件的回复。该脚本在过去几个月中运行良好，但现在它在我的收件箱（outlook）中找不到（随机？）某些项目 我已经根据每封电子邮件中的 3 个标准构建了一个 DASL 过滤器。 我不确定这是否是引用我的 Outlook 文件夹的问题。在计算我的收件箱中受过滤器限制的项目时，items.count 返回 0，这是不正确的。 我知道我的 DASL 过滤器不是最好的，但我在字符串连接方面有点挣扎。我正在分享我可以成功找到的电子邮件的屏幕截图。用于查找该电子邮件的标准以红色突出显示。

screenshot of test email

Sub Search_InboxAndHighlight()

Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.Namespace
'Dim objFolder As Outlook.MAPIFolder
Dim objFolder As Outlook.Folder
Dim filteredItems As Outlook.Items
Dim Sup_ENg_Number As Range
Dim OGDD_Programs As Range
Dim strFilter As String
Dim compName As String
Dim supNumber As String
Dim Program_type as String

'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)


Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set fol = objNamespace.Folders("myEmailaddress").Folders("Sent Items")


"loop through cells on activesheet

For Each Sup_ENg_Number In OGDD_Programs

  supNumber = "'" & Sup_ENg_Number.Value & "'"
   compName = Sup_ENg_Number.Offset(, 1).Value
   compName = "'" & compName & "'"
  Program_type = "'" & Sup_ENg_Number..Offset(, 3)Value & "'"

   ' filter to search sup_eng_number  and company name in body of the eemail
     strFilter = "@SQL=""urn:schemas:httpmail:textdescription"" ci_phrasematch " & supNumber
     strFilter = strFilter & " AND "
     strFilter = strFilter & """urn:schemas:httpmail:textdescription"" ci_phrasematch " & compName
     strFilter = strFilter & " AND "
     strFilter = strFilter & """urn:schemas:httpmail:textdescription"" ci_phrasematch " & Program_type
  
   'restrict items to lookup to be only of the filter "strFilter"
    Set filteredItems = objFolder.Items.Restrict(strFilter)
    Set SentFilteredItems = fol.Items.Restrict(strFilter)

    If filteredItems.Count = 0 AND SentFilteredItems.Count = 0 then

      Sup_ENg_Number.Interior.Color = vbRed
   end if
Next Sup_ENg_Number 

 MsgBox "Completed!"

'If the subject isn't found:
If Not Found Then
    'NoResults.Show
Else
   'Debug.Print "Found " & filteredItems.Count & " items."

End If
Application.ScreenUpdating = True
'myOlApp.Quit
Set myOlApp = Nothing

End Sub

Answer 1

如果您有多个收件箱，则默认收件箱可能不再是原来的。

而不是

Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

保持一致

Set objFolder = objNamespace.Folders("myEmailaddress").Folders("Inbox")

Answer 2

我重写了删除 Excel 的代码。

这个显然不错代码遵循https://docs.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder中的示例。

它会找到旧邮件，但找不到正文中带有“Test”的新测试电子邮件。
忘了我正在测试默认邮箱和辅助邮箱。代码有效。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Sub Search_Inbox()

    ' Code for Outlook not Excel
        
    Dim objFolder As folder
    Dim fol As folder
    
    Dim filteredItems As Items
    Dim SentFilteredItems As Items
    
    Dim strFilter As String
    Dim supNumber As String
    
    Dim i As Long
    
    'Default Inbox
    'Set objFolder = Session.GetDefaultFolder(olFolderInbox)
    'Set fol = Session.GetDefaultFolder(olFolderSentMail)

    'Any inbox
    Set objFolder = Session.folders("myEmailaddress").folders("Inbox")
    'Set fol = Session.folders("myEmailaddress").folders("Sent")
    Set fol = Session.folders("myEmailaddress").folders("Sent Items")

    'https://docs.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
    If (Session.DefaultStore.IsInstantSearchEnabled) Then
    
        ' compare this sample filter to your filter for supNumber
        strFilter = "@SQL=" & Chr(34) _
          & "urn:schemas:httpmail:textdescription" & Chr(34) _
          & " ci_phrasematch 'office'"
        Debug.Print strFilter
        
        supNumber = "Test"
        'Debug.Print supNumber
        supNumber = "'" & supNumber & "'"
        'Debug.Print supNumber
        
        ' filter to search for supNumber
        strFilter = "@SQL=""urn:schemas:httpmail:textdescription"" ci_phrasematch " & supNumber
        Debug.Print strFilter
        
        'restrict items
        Set filteredItems = objFolder.Items.Restrict(strFilter)
        Debug.Print "Found " & filteredItems.Count & " inbox items."
        
        Set SentFilteredItems = fol.Items.Restrict(strFilter)
        Debug.Print "Found " & SentFilteredItems.Count & " sent items."
        
        If filteredItems.Count = 0 And SentFilteredItems.Count = 0 Then
            Debug.Print "No items found."
        Else
            For i = 1 To filteredItems.Count
                Debug.Print filteredItems(i).subject
                Debug.Print filteredItems(i).ReceivedTime
                Debug.Print filteredItems(i).body
            Next
            
            For i = 1 To SentFilteredItems.Count
                Debug.Print SentFilteredItems(i).subject
                Debug.Print SentFilteredItems(i).ReceivedTime
                Debug.Print SentFilteredItems(i).body
            Next
            
        End If
        
        MsgBox "Completed!"
        
    Else
    
        MsgBox "Experiment with like. May be buggy as well."
        
    End If

End Sub

您在评论中说“我有一些电子邮件，我昨天可以找到，但今天我的脚本找不到它们。”

如果没有关于您看到的不可靠性的解释，您可以尝试使用 like 而不是 ci_phrasematch。您可以考虑使用.Find。