按主题、发件人和日期在 Excel 范围内搜索每个电子邮件地址的收件箱

Question

我在收件箱文件夹中搜索给定主题、第 1 列的发件人和日期。

根据结果，它应该用 Yes 或 No 填充第 2 列中的行。但它会将所有行填充为 No。我确定我应该至少看到一个 Yes。

变量 i 的值总是什么都没有。看起来是 filterstring 变量的问题。

Sub searchemailsreceived()
Application.ScreenUpdating = False

ThisWorkbook.Activate

Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim i As Object
Dim mi As outlook.MailItem
Dim filterstring As String
Dim dmi As outlook.MailItem
Dim lstRow As Long
Dim rng As Range

ThisWorkbook.Sheets("Sheet1").Activate

lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Set rng = Range("A2:A" & lstRow)
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set dmi = ol.CreateItem(olMailItem)

For Each cell In rng
    filterstring = "@SQL=(""urn:schemas:httpmail:fromemail"" LIKE '%" & Range(cell.Address).Offset(0, 0).Value2 & "%' AND ""urn:schemas:httpmail:subject"" LIKE '%This is my subject%' AND ""urn:schemas:httpmail:datereceived"" >= '4/1/2021 12:00 AM')"
    For Each i In fol.Items.Restrict(filterstring)
        If i.Class = olMail Then
            Range(cell.Address).Offset(0, 1).Value2 = "Yes"
            GoTo landhere
        End If
    Next i
    Range(cell.Address).Offset(0, 1).Value2 = "No"
landhere:
Next cell

Set mi = Nothing
Set dmi = Nothing
Set ol = Nothing
Application.ScreenUpdating = False
End Sub

Answer 1

尝试以下清理后的功能（未经测试）：

Sub SearchEmailsReceived()
    Application.ScreenUpdating = False
    
    Dim ol As Outlook.Application: Set ol = New Outlook.Application
    Dim fol As Outlook.MAPIFolder: Set fol = ol.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim lstRow As Long: lstRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
    Dim rng As Range: Set rng = ws.Range("A2:A" & lstRow)
    
    Dim i As Object, filterstring As String, Cell As Range

    Dim dmi As Outlook.MailItem: Set dmi = ol.CreateItem(olMailItem)
    For Each Cell In rng
        filterstring = "@SQL=urn:schemas:httpmail:fromemail LIKE '%" & Cell.Value2 & "%' AND urn:schemas:httpmail:subject LIKE '%This is my subject%' AND urn:schemas:httpmail:datereceived >= '4/1/2021 12:00 AM'"
        Cell.Offset(0, 1) = "No"
        For Each i In fol.Items.Restrict(filterstring)
            If i.Class = olMail Then Cell.Offset(0, 1) = "Yes"
        Next i
    Next Cell
    
    Set dmi = Nothing
    Set ol = Nothing
    Application.ScreenUpdating = False
End Sub

@niton 链接的答案显示SQL=urn... 不包含引号，因此它们已被删除。您可能希望减少过滤器字符串并测试每个附加的 AND 语句是否会导致问题。也许注释掉主题和日期以测试它是否首先找到收件人的任何电子邮件，然后在您知道基础工作正常后将它们返回到进一步的要求中

Answer 2

fromemail 架构对我不起作用。对我有用的是""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%'

感谢您的帮助。

Answer 3

使用“urn:schemas:httpmail:fromemail”和“proptag/0x0065001f”进行演示。

Option Explicit

Sub searchemailsreceived_Demo()

'Application.ScreenUpdating = False

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace

Dim fol As Outlook.Folder

Dim folItems As Outlook.Items

Dim folItemsSQL As Outlook.Items

Dim folItems1SQL As Outlook.Items
Dim folItems2SQL As Outlook.Items
Dim folItems3SQL As Outlook.Items

Dim i As Long

Dim filterString1 As String
Dim filterString2 As String
Dim filterString3 As String

Dim filterStringSQL As String

Dim filterString1SQL As String
Dim filterString2SQL As String
Dim filterString3SQL As String

Dim lastRowColA As Long
Dim rng As Range
Dim cell As Object
Dim foundFlag As Boolean

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")

lastRowColA = Cells(Rows.Count, 1).End(xlUp).Row

Set rng = Range("A2:A" & lastRowColA)

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)

Set folItems = fol.Items
Debug.Print "folItems.Count..: " & folItems.Count
    
For Each cell In rng
    
    'filterString1 = """http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & cell.Value2 & "%'"
    
    ' or
    
    ' Based on sample data, a filter without wildcards may be preferable.
    ' Col A = email addresses starting in row 2
    Debug.Print
    filterString1 = """urn:schemas:httpmail:fromemail"" LIKE '" & cell.Value2 & "'"
    Debug.Print "filterString1 ..: " & filterString1

    filterString1SQL = "@SQL=(" & filterString1 & ")"
    Debug.Print "filterString1SQL: " & filterString1SQL
    
    Set folItems1SQL = folItems.Restrict(filterString1SQL)
    Debug.Print "folItems1SQL.Count.: " & folItems1SQL.Count
    
    ' Condition 1
    foundFlag = False
    For i = 1 To folItems1SQL.Count
        If folItems1SQL(i).Class = olMail Then
            Debug.Print "i = " & i
            Debug.Print " - folItems1SQL(i).SenderEmailAddress: " & folItems1SQL(i).SenderEmailAddress
            cell.Offset(0, 2).Value2 = "Yes"
            foundFlag = True
            Exit For
        End If
    Next
    
    If foundFlag = False Then
        cell.Offset(0, 2).Value2 = "No"
    End If
    
    
    ' Condition 2
    Dim strSubject As String
    strSubject = "test"
    
    Debug.Print
        
    filterString2 = """urn:schemas:httpmail:subject"" LIKE '%" & strSubject & "%'"
    Debug.Print "filterString2 ..: " & filterString2
    
    filterString2SQL = "@SQL=(" & filterString2 & ")"
    Debug.Print "filterString2SQL: " & filterString2SQL
    
    Set folItems2SQL = folItems.Restrict(filterString2SQL)
    Debug.Print "folItems2SQL.Count.: " & folItems2SQL.Count
    
    foundFlag = False
    For i = 1 To folItems2SQL.Count
        If folItems2SQL(i).Class = olMail Then
            Debug.Print "i = " & i
            Debug.Print " - folItems2SQL(i).Subject: " & folItems2SQL(i).Subject
            cell.Offset(0, 3).Value2 = "Yes"
            foundFlag = True
            Exit For
        End If
    Next
        
    If foundFlag = False Then
        cell.Offset(0, 3).Value2 = "No"
    End If
    
    
    ' Condition 3
    Dim strDate As String
    strDate = "2021/04/01 12:00 AM"
    
    Debug.Print
        
    filterString3 = """urn:schemas:httpmail:datereceived"" >= '" & strDate & "'"
    Debug.Print "filterString3: " & filterString3
    
    filterString3SQL = "@SQL=(" & filterString3 & ")"
    Debug.Print "filterString3SQL: " & filterString3SQL
    
    Set folItems3SQL = folItems.Restrict(filterString3SQL)
    Debug.Print "folItems3SQL.Count : " & folItems3SQL.Count
    
    foundFlag = False
    For i = 1 To folItems3SQL.Count
        If folItems3SQL(i).Class = olMail Then
            Debug.Print "i = " & i
            Debug.Print " - folItems3SQL(i).ReceivedTime: " & folItems3SQL(i).ReceivedTime
            cell.Offset(0, 4).Value2 = "Yes"
            foundFlag = True
            Exit For
        End If
    Next
        
    If foundFlag = False Then
        cell.Offset(0, 4).Value2 = "No"
    End If
    
    
    '  Condition 1 AND Condition 2 AND Condition 3
    Debug.Print
    Debug.Print filterString1
    Debug.Print filterString2
    Debug.Print filterString3
    
    filterStringSQL = "@SQL=(" & filterString1 & " AND " & filterString2 & " AND " & filterString3 & ")"
    Debug.Print "filterStringSQL: " & filterStringSQL
    
    Set folItemsSQL = folItems.Restrict(filterStringSQL)
    Debug.Print "folItemsSQL.Count : " & folItemsSQL.Count
    
    foundFlag = False
    
    For i = 1 To folItemsSQL.Count
        If folItemsSQL(i).Class = olMail Then
            Debug.Print "i = " & i
            Debug.Print " - folItemsSQL(i).SenderEmailAddress: " & folItemsSQL(i).SenderEmailAddress
            Debug.Print " - folItemsSQL(i).Subject...........: " & folItemsSQL(i).Subject
            Debug.Print " - folItemsSQL(i).ReceivedTime......: " & folItemsSQL(i).ReceivedTime
            Debug.Print
            cell.Offset(0, 1).Value2 = "Yes"
            foundFlag = True
            Exit For
        End If
    Next
    
    If foundFlag = False Then
        cell.Offset(0, 1).Value2 = "No"
    End If

Next cell

Application.ScreenUpdating = True

End Sub

Answer 4

实际上我尝试了一个较小的，它工作，但谢谢。

Sub searchemailsreceived()
Application.ScreenUpdating = False

ThisWorkbook.Activate

Dim ol As Outlook.Application: Set ol = New Outlook.Application
Dim ns As Outlook.Namespace: Set ns = ol.GetNamespace("MAPI")
Dim fol As Outlook.Folder: Set fol = ns.GetDefaultFolder(olFolderInbox)
Dim filterstring As String
Dim lstRow As Long: lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range: Set rng = Range("A2:A" & lstRow)

ThisWorkbook.Sheets("Sheet1").Activate

For Each Cell In rng
    filterstring = "@SQL=(""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%' AND ""urn:schemas:httpmail:subject"" LIKE '%This is a subject%' AND ""urn:schemas:httpmail:datereceived"" >= '1/1/2000 12:00 AM')"
    Range(Cell.Address).Offset(0, 2).Value2 = fol.Items.Restrict(filterstring).Count
    filterstring = ""
Next Cell

Set ol = Nothing
Application.ScreenUpdating = False
End Sub