使用 urn:schemas 按电子邮件地址搜索

Posted 2023-02-16

【中文标题】使用 urn:schemas 按电子邮件地址搜索

【英文标题】：Search by Email address with urn:schemas

【发布时间】：2020-12-04 08:56:01

【问题描述】：

我从 Ricardo Diaz 那里找到了this code。它贯穿始终。

我想搜索我收到或发送到特定电子邮件地址的最新电子邮件，而不是按主题搜索。

我换了

searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'"

与

searchString = "urn:schemas:httpmail:to like '" & emailSubject & "'"

搜索返回一个空对象。

在我的 Outlook 收件箱和已发送邮件中搜索发件人和收件人的电子邮件地址的 urn:schemas 是什么？

这是我要运行的代码：

在 VBA 模块中：

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://***.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

在名为 clsOutlook 的类模块中：

Option Explicit

' Credits: Based on this answer: https://***.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 包含电子邮件地址，例如[e-mail]。

【问题讨论】：

将 searchString = "urn:schemas:httpmail:to like '" & emailSubject & "'" 更改为 searchString = "urn:schemas:httpmail:displayto like '" & emailSubject & "'"，并使用 Outlook 活动用户帐户（如 emailSubject），它看起来会返回最后发送的邮件......没有回答你的问题。只玩它... :)

这个?activeexplorer.Selection.Item(1).propertyaccessor.getproperty("urn:schemas:httpmail:to") 返回一个错误，指出To 不是有效属性，但这个docs.microsoft.com/en-us/previous-versions/office/developer/… 另有说明。 DisplayTo 正如@FaneDuru 指出的那样工作，但只是To 不可读。奇数。

Dick Kusleika：看起来应该是，但由于未知原因它没有...请参阅here...

@FaneDuru，使用DisplayTo 有效，但在很多情况下我不知道 Outlook 活动用户帐户，我只知道电子邮件地址。最终，代码应该遍历我过去联系过的许多电子邮件地址，而我只知道他们的姓名和电子邮件地址。

就像我上面说的，我不想暗示我的评论试图回答你的问题。这只是我正在玩的东西，并且正确地返回了一些东西。我没有测试，事实上我不能，在 Outlook 中没有第二个帐户，如果它返回活动帐户或所有帐户。无论如何，如果你想重播，我认为自动回复将使用活动帐户完成。然后，我（仅）假设查询可以接受更多条件。如果是这样，其中一个可以是发件人帐户...

【参考方案1】：

您可以通过另一种方式访问​​看似“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 = "[e-mail]"
    
    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

【讨论】：

谢谢，Niton - 我会试一试

尼顿，谢谢。我理解你的代码并且它运行通过。正如您所指出的，我也在努力获得正确的模式来返回电子邮件收件人的电子邮件地址。我从您提供的链接中尝试了不同的架构，但它们没有返回任何值。