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

Question

我从 Ricardo Diaz那里找到了这段代码。它贯穿。

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

我换了

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

在名为 clsOutlook 的类模块中：

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 包含电子邮件地址，例如[e-mail]。

标签： vbaoutlookadvanced-search

Answer 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 = "[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