如何检索任何外部电子邮件地址？

Question

我有在我发送电子邮件时运行的代码。它会查看收件人地址和主题，看看它是否包含某些单词，然后弹出一个消息框提醒我们更新我们的绘图修订控制。

它适用于内部电子邮件地址，似乎也适用于某些外部电子邮件地址。它不喜欢我需要寻找的电子邮件地址。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim hismail As String
Dim strSubject As String
strSubject = Item.Subject

Dim olObj As MailItem

Set olObj = Application.ActiveInspector.CurrentItem
hismail = olObj.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
Set olObj = Nothing

If hismail = "David@abclimited.net" And strSubject Like "*update*" Or strSubject Like "*revision*" Then

    MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"

End If
End Sub

我在这篇文章中更改了地址，但格式和长度相同。

Answer 1

经过一番挖掘后，我找到了一个解决方案，可以让您指出正确的方向。这是基于怀疑您的问题是由于您的目标用户在您组织的 Exchange 服务器中不可用。此解决方案应该解决问题，但如果不能解决，它至少会让您知道下一步该往哪里看。

首先，我从这篇 MSDN 文章 (https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/obtain-the-e-mail-address-of-a-recipient) 中获取了代码示例，并对其进行了修改，使其返回一组地址用户及其电子邮件：

Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
    Dim Recipients As Outlook.Recipients
    Set Recipients = MailItem.Recipients

    Dim Addresses As Variant
    ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)

    Dim Accessor As Outlook.PropertyAccessor

    Dim Recipient As Outlook.Recipient
    For Each Recipient In Recipients
        Set Accessor = Recipient.PropertyAccessor

        Dim i As Long
        Addresses(i, 0) = Recipient.Name
        Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)

        i = i + 1
    Next

    GetSMTPAddressesForRecipients = Addresses
End Function

这将遍历电子邮件中的所有收件人，并捕获他们的姓名和电子邮件，将每个收件人放入数组中的下一个位置。接下来，我们需要在您的例程中使用这些信息：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
    Dim EmailSubject As String
    EmailSubject = LCase(Item.Subject)

    If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
        Dim Addresses As Variant
        Addresses = GetSMTPAddressesForRecipients(Item)

        Dim i As Long
        For i = LBound(Addresses, 1) To UBound(Addresses, 1)
            If Addresses(i, 1) = "David@abclimited.net" Then
                MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
                Exit For
            End If
        Next
    End If
End Sub

这里有几点需要注意。首先，您的模式使用小写作为主题，因此您需要将主题转换为小写，这样，如果您有“更新修订”之类的主题，您的模式仍然可以捕捉到它。

其次，我把最可能的条件放在前面，即您的大多数电子邮件主题不会包含“主题”或“修订”。无需再向服务器询问收件人的地址。以前，您的代码会在检查它是否需要之前获取地址。最好只询问我们需要什么，这样可以使您的代码更易于阅读和维护，同时还可以降低任何处理成本。

最后，这段代码将遍历所有地址，而不仅仅是查看第一个地址。通过这样做，即使他是列表中的第二个、第三个或第五十个地址，您仍然会触发警报。

我希望这会有所帮助！这是完整的代码：

Option Explicit

Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
    Dim EmailSubject As String
    EmailSubject = LCase(Item.Subject)

    If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
        Dim Addresses As Variant
        Addresses = GetSMTPAddressesForRecipients(Item)

        Dim i As Long
        For i = LBound(Addresses, 1) To UBound(Addresses, 1)
            If Addresses(i, 1) = "David@abclimited.net" Then
                MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
                Exit For
            End If
        Next
    End If
End Sub

Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
    Dim Recipients As Outlook.Recipients
    Set Recipients = MailItem.Recipients

    Dim Addresses As Variant
    ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)

    Dim Accessor As Outlook.PropertyAccessor

    Dim Recipient As Outlook.Recipient
    For Each Recipient In Recipients
        Set Accessor = Recipient.PropertyAccessor

        Dim i As Long
        Addresses(i, 0) = Recipient.Name
        Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)

        i = i + 1
    Next

    GetSMTPAddressesForRecipients = Addresses
End Function