问题描述
我是这个论坛的新手。我从里卡多·迪亚兹（Ricardo Diaz）找到了this code。它贯穿。但是，我想修改代码以搜索收到或发送到特定电子邮件地址的最新电子邮件，而不是通过主题进行搜索。
因此我替换了
searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'"
使用
searchString = "urn:schemas:httpmail:to like '" & emailSubject & "'"
不幸的是，搜索确实返回了一个空对象。在Outlook收件箱和“已发送邮件”中搜索发件人和收件人的电子邮件地址的正确urn：schemas是什么？
为完整起见，这是我要运行的代码：
Public Sub ProcessEmails()
Dim testOutlook As Object
Dim oOutlook As clsOutlook
Dim searchRange As Range
Dim subjectCell As Range
Dim searchFolderName As String
' 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")
For Each subjectCell In searchRange
' Only to cells with actual subjects
If subjectCell.Value <> vbNullString Then
Call oOutlook.SearchAndReply(subjectCell.Value,searchFolderName,False)
End If
Next subjectCell
MsgBox "Search and reply completed"
' Clean object
Set testOutlook = nothing
End Sub
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
' Handler for Advanced search complete
Private Sub outlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
'MsgBox "The AdvancedSearchComplete Event fired."
searchComplete = True
End Sub
Sub SearchAndReply(emailSubject As String,searchFolderName As String,searchSubFolders As Boolean)
' Declare objects variables
Dim customMailItem As Outlook.MailItem
Dim searchString As String
Dim resultItem As Integer
' Variable defined at the class level
Set OutlookApp = New outlook.application
' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
searchComplete = False
' You can look up on the internet for urn:schemas strings to make custom searches
searchString = "urn:schemas:httpmail:to like '" & emailSubject & "'"
' Perform advanced search
Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName,searchString,searchSubFolders,"SearchTag")
' 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 Exit Sub
' 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.display
End Sub
Sheet1中的A2：A4单元格包含电子邮件地址，例如[email protected]。
感谢您的帮助。
解决方法
您可以通过另一种方式查看“ urn：schemas：httpmail：to”。
Read MAPI properties not exposed in Outlook's Object Model
仍然有用，因为与地址相关的属性中的值不可用或微不足道。
Option Explicit
' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
Const PR_RECEIVED_BY_NAME As String = "http://schemas.microsoft.com/mapi/proptag/0x0040001E"
Const PR_SENT_REPRESENTING_NAME As String = "http://schemas.microsoft.com/mapi/proptag/0x0042001E"
Const PR_RECEIVED_BY_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0076001E"
Const PR_SENT_REPRESENTING_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0065001E"
Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001E"
Sub ShowPropertyAccessorValue()
Dim oItem As Object
Dim propertyAccessor As outlook.propertyAccessor
' for testing
' select an item from any folder not the Sent folder
' then an item from the Sent folder
Set oItem = ActiveExplorer.Selection.item(1)
If oItem.Class = olMail Then
Set propertyAccessor = oItem.propertyAccessor
Debug.Print
Debug.Print "oItem.Parent......................: " & oItem.Parent
Debug.Print "Sender Display name...............: " & oItem.Sender
Debug.Print "Sender address....................: " & oItem.SenderEmailAddress
Debug.Print "PR_RECEIVED_BY_NAME...............: " & _
propertyAccessor.GetProperty(PR_RECEIVED_BY_NAME)
Debug.Print "PR_SENT_REPRESENTING_NAME.........: " & _
propertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)
Debug.Print "PR_RECEIVED_BY_EMAIL_ADDRESS......: " & _
propertyAccessor.GetProperty(PR_RECEIVED_BY_EMAIL_ADDRESS)
Debug.Print "PR_SENT_REPRESENTING_EMAIL_ADDRESS: " & _
propertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS)
Debug.Print "PR_SENDER_EMAIL_ADDRESS...........: " & _
propertyAccessor.GetProperty(PR_SENDER_EMAIL_ADDRESS)
End If
End Sub
Filtering Items Using a String Comparison
中的示例格式Private Sub RestrictBySchema()
Dim myInbox As Folder
Dim myFolder As Folder
Dim propertyAccessor As propertyAccessor
Dim strFilter As String
Dim myResults As Items
Dim mailAddress As String
' for testing
' open any folder not the Sent folder
' then the Sent folder
Set myFolder = ActiveExplorer.CurrentFolder
Debug.Print "myFolder............: " & myFolder
Debug.Print "myFolder.items.Count: " & myFolder.Items.Count
mailAddress = "[email protected]"
Debug.Print "mailAddress: " & mailAddress
' Filtering Items Using a String Comparison
' https://docs.microsoft.com/en-us/office/vba/outlook/how-to/search-and-filter/filtering-items-using-a-string-comparison
'strFilter = "@SQL=""https://schemas.microsoft.com/mapi/proptag/0x0037001f"" = 'the right ""stuff""'"
'Debug.Print "strFilter .....: " & strFilter
' Items where PR_RECEIVED_BY_EMAIL_ADDRESS = specified email address
' This is the To
' No result from the Sent folder
' Logical as the item in the Sent folder could have multiple receivers
Debug.Print
Debug.Print "PR_RECEIVED_BY_EMAIL_ADDRESS"
strFilter = "@SQL=" & """" & PR_RECEIVED_BY_EMAIL_ADDRESS & """" & " = '" & mailAddress & "'"
Debug.Print "strFilter .....: " & strFilter
Set myResults = myFolder.Items.Restrict(strFilter)
Debug.Print " myResults.Count.....: " & myResults.Count
' Items where PR_SENT_REPRESENTING_EMAIL_ADDRESS = specified email address
Debug.Print
Debug.Print "PR_SENT_REPRESENTING_EMAIL_ADDRESS"
strFilter = "@SQL=" & """" & PR_SENT_REPRESENTING_EMAIL_ADDRESS & """" & " = '" & mailAddress & "'"
Debug.Print "strFilter .....: " & strFilter
Set myResults = myFolder.Items.Restrict(strFilter)
Debug.Print " myResults.Count.....: " & myResults.Count
' Items where SenderEmailAddress = specified email address
Debug.Print
Debug.Print "SenderEmailAddress"
strFilter = "[SenderEmailAddress] = '" & mailAddress & "'"
Debug.Print "strFilter .....: " & strFilter
Set myResults = myFolder.Items.Restrict(strFilter)
Debug.Print " myResults.Count.....: " & myResults.Count
' Items where PR_SENDER_EMAIL_ADDRESS = specified email address
Debug.Print
Debug.Print "PR_SENDER_EMAIL_ADDRESS"
strFilter = "@SQL=" & """" & PR_SENDER_EMAIL_ADDRESS & """" & " = '" & mailAddress & "'"
Debug.Print "strFilter .....: " & strFilter
Set myResults = myFolder.Items.Restrict(strFilter)
Debug.Print " myResults.Count.....: " & myResults.Count
End Sub