问题
I am new to this forum. I have found this code from Ricardo Diaz. It runs through. However, I would like to amend the code to search for the latest email I received or sent to a specific email address as opposed to search by subject.
I have therefore replaced
searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'"
with
searchString = "urn:schemas:httpmail:to like '" & emailSubject & "'"
Unfortunately, the search does return an empty object. What is the correct urn:schemas to search for the email address of the sender and receiver in my Outlook Inbox and Sent Items?
For completeness, this is the code that I am trying to run:
Add in a vba module this code:
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
Then add a class module and name it: clsOutlook
To the class module add the following code:
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
The cells A2:A4 in Sheet1 contain email address such as rainer@gmail.com for instance.
I appreciate your help.
回答1:
You can get to what appears to be "urn:schemas:httpmail:to" another way.
Read MAPI properties not exposed in Outlook's Object Model
The usefulness is still to be proven as the values from the the address-related properties are either not available or trivial.
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
Example format from 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@somewhere.com"
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
来源：https://stackoverflow.com/questions/63413285/search-by-email-address-for-latest-email-in-all-folders-and-reply-all