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）中获取了代码示例并进行了修改，以便它返回一个Address Users及其电子邮件数组：

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

这里有几点需要注意。首先，您的模式使用小写字母作为主题，因此您需要将主题转换为小写，以便，如果您有一个类似＆＃34的主题;更新修订版＆＃34;你的模式仍然可以捕获它。

其次，我预先设置了最可能的条件，即大部分电子邮件主题都不包含＆＃34;主题＆＃34;或＆＃34;修订版＆＃34;。然后，无需向服务器询问收件人的地址。以前，您的代码会在检查是否需要之前获取地址。它最好只询问我们需要什么，它使您的代码更易于阅读和维护，同时还降低了任何处理成本。

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

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

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

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

1 个答案: