按主题、发件人和日期搜索 Excel 范围内每个电子邮件地址的收件箱
Search Inbox by Subject, Sender and Date for each email address in Excel range
我在收件箱文件夹中搜索第 1 列中的给定主题、发件人和日期。
根据结果，它应该将第 2 列中的行填充为是或否。但它会将所有行填充为否。我确定我应该至少看到一个是。
变量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
尝试以下清理函数（未经测试）：
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 语句是否会导致问题。也许注释掉主题和日期以测试它是否首先找到来自收件人的任何电子邮件，然后在您知道基本工作正常后将它们返回到进一步的要求中
fromemail 模式对我不起作用。对我有用的是 ""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%'
感谢您的帮助。
使用“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
实际上我尝试了一个更小的并且它起作用了但是谢谢你。
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
我在收件箱文件夹中搜索第 1 列中的给定主题、发件人和日期。
根据结果，它应该将第 2 列中的行填充为是或否。但它会将所有行填充为否。我确定我应该至少看到一个是。
变量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
尝试以下清理函数（未经测试）：
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 语句是否会导致问题。也许注释掉主题和日期以测试它是否首先找到来自收件人的任何电子邮件，然后在您知道基本工作正常后将它们返回到进一步的要求中
fromemail 模式对我不起作用。对我有用的是 ""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%'
感谢您的帮助。
使用“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
实际上我尝试了一个更小的并且它起作用了但是谢谢你。
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