Outlook VBA从Outlook获取别名地址。收件人

Question

重写说明： 我们在公司内部使用Office 365 Outlook Exchange。目前，我们有许多与客户相关的电子邮件，它们都有各自独立的帐户。例如support @ google.com，sales @ google.com和customerservice@google.com等。为了节省成本，提出了一个主意，而不是为所有这些与客户相关的不同帐户付款，而是为每个帐户创建电子邮件别名。将它们合并到一个帐户（即task@google.com）中。

这应该很好用，但是我们遇到的主要问题是Outlook.Recipient电子邮件地址始终显示task@google.com。这没有告诉我客户实际上是在尝试发送电子邮件的人。我需要知道客户实际尝试通过电子邮件发送的别名。

这是我用来尝试提取别名的代码示例...但是它返回的是实际的帐户电子邮件，即task@google.com而不是别名。

Function GetEmailRecipient(mail As Outlook.MailItem) As String
    Dim Recips As Outlook.Recipients
    Dim Recip As Outlook.Recipient
    Dim Pa As Outlook.PropertyAccessor
    Dim ToEmail As String

    Set Recips = mail.Recipients
    For Each Recip In Recips
        Set Pa = Recip.PropertyAccessor
        If ToEmail > "" Then
            ToEmail = ToEmail & ";" &Recip.AddressEntry.GetExchangeUser.Alias
        Else
            ToEmail = Recip.AddressEntry.GetExchangeUser.Alias
        End If
    Next
    GetEmailRecipient = ToEmail
End Function

Answer 1

这可能有帮助。

从这些电子邮件中选择一些，然后运行以下宏，该宏将为每个选定的电子邮件输出整个SMTP标头。

请注意，立即窗口的限制为大约200行。我通常将这样的诊断信息输出到文件中。如果您想要该宏版本的副本，很高兴添加它。

Sub OutHeader()

  Dim Exp As Outlook.Explorer
  Dim ItemCrnt As MailItem
  Dim PropAccess As Outlook.propertyAccessor

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Debug.Print "No emails selected"
  Else
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        Set PropAccess = .propertyAccessor
        Debug.Print "--------------"
        Debug.Print PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
      End With
    Next
  End If

End Sub

Answer 2

我遇到的主要问题@TonyDallimore帮助我解决了上面公认的答案。但是，我仍然需要从标题中检索收件人属性。以下代码是我与Tony的代码以及我自己的解析函数结合使用的。它将完整的电子邮件标头解析为一个数组。

Function GetEmailRecipient(msg As Outlook.MailItem) As String
    Dim Recips As Outlook.Recipients
    Dim Recip As Outlook.Recipient
    Dim Pa As Outlook.PropertyAccessor
    Dim EmailHeader As String
    Dim HeaderProperties As Variant
    Dim Recepient As String
    Dim i As Integer

    Set Pa = msg.PropertyAccessor
    EmailHeader = Pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
    ' Parse Header Into Array
    HeaderProperties = ParseEmailHeader(EmailHeader)
    ' Capture Recepient Email Value
    For i = LBound(HeaderProperties) To UBound(HeaderProperties)
            ' Array Index
            Debug.Print HeaderProperties(i, 0)
            ' Header Property Name
            Debug.Print HeaderProperties(i, 1)
            ' Header Property Value
            Debug.Print HeaderProperties(i, 2)
    Next
    GetEmailRecipient = Recepient
End Function

Private Function ParseEmailHeader(EmailHeader As String) As Variant
    Dim Delim As String
    Dim Arr As Variant
    Dim Arr2 As Variant
    Dim ArrRet As Variant
    Dim i As Integer
    Dim PropertyName As String
    Dim PropertyValue As String


    Delim = EmailHeader
    ' Add delimiters into header string
    Delim = Replace(Delim, "Received:", "~Received:")
    Delim = Replace(Delim, "Authentication-Results:", "~Authentication-Results:")
    Delim = Replace(Delim, "Content-Type:", "~Content-Type:")
    Delim = Replace(Delim, "Content-Transfer-Encoding:", "~Content-Transfer-Encoding:")
    Delim = Replace(Delim, "From:", "~From:")
    Delim = Replace(Delim, "To:", "~To:")
    Delim = Replace(Delim, "Subject:", "~Subject:")
    Delim = Replace(Delim, "Thread-Topic:", "~Thread-Topic:")
    Delim = Replace(Delim, "Thread-Index:", "~Thread-Index:")
    Delim = Replace(Delim, "Date:", "~Date:")
    Delim = Replace(Delim, "Message-ID:", "~Message-ID:")
    Delim = Replace(Delim, "Accept-Language:", "~Accept-Language:")
    Delim = Replace(Delim, "Content-Language:", "~Content-Language:")
    Delim = Replace(Delim, "X-MS-Has-Attach:", "~X-MS-Has-Attach:")
    Delim = Replace(Delim, "X-MS-Has-Attach:", "~X-MS-Has-Attach:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-SCL:", "~X-MS-Exchange-Organization-SCL:")
    Delim = Replace(Delim, "X-MS-TNEF-Correlator:", "~X-MS-TNEF-Correlator:")
    Delim = Replace(Delim, "MIME-Version:", "~MIME-Version:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-MessageDirectionality:", "~X-MS-Exchange-Organization-MessageDirectionality:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-AuthSource:", "~X-MS-Exchange-Organization-AuthSource:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-AuthAs:", "~X-MS-Exchange-Organization-AuthAs:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-AuthMechanism:", "~X-MS-Exchange-Organization-AuthMechanism:")
    Delim = Replace(Delim, "X-Originating-IP:", "~X-Originating-IP:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-Network-Message-ID:", "~X-MS-Exchange-Organization-Network-Message-ID:")
    Delim = Replace(Delim, "X-MS-PublicTrafficType:", "~X-MS-PublicTrafficType:")
    Delim = Replace(Delim, "X-Microsoft-Exchange-Diagnostics:", "~X-Microsoft-Exchange-Diagnostics:")
    Delim = Replace(Delim, "X-MS-Exchange-Antispam-SRFA-Diagnostics:", "~X-MS-Exchange-Antispam-SRFA-Diagnostics:")
    Delim = Replace(Delim, "Return-Path:", "~Return-Path:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-ExpirationStartTime:", "~X-MS-Exchange-Organization-ExpirationStartTime:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-ExpirationStartTimeReason:", "~X-MS-Exchange-Organization-ExpirationStartTimeReason:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-ExpirationInterval:", "~X-MS-Exchange-Organization-ExpirationInterval:")
    Delim = Replace(Delim, "X-MS-Exchange-Organization-ExpirationIntervalReason:", "~X-MS-Exchange-Organization-ExpirationIntervalReason:")
    Delim = Replace(Delim, "X-MS-Office365-Filtering-Correlation-Id:", "~X-MS-Office365-Filtering-Correlation-Id:")
    Delim = Replace(Delim, "X-Microsoft-Antispam:", "~X-Microsoft-Antispam:")
    Delim = Replace(Delim, "X-MS-TrafficTypeDiagnostic:", "~X-MS-TrafficTypeDiagnostic:")
    Delim = Replace(Delim, "X-Exchange-Antispam-Report-Test:", "~X-Exchange-Antispam-Report-Test:")
    Delim = Replace(Delim, "UriScan:", "~UriScan:")
    Delim = Replace(Delim, "X-Exchange-Antispam-Report-CFA-Test:", "~X-Exchange-Antispam-Report-CFA-Test:")
    Delim = Replace(Delim, "X-Forefront-Antispam-Report:", "~X-Forefront-Antispam-Report:")
    Delim = Replace(Delim, "SpamDiagnosticOutput:", "~SpamDiagnosticOutput:")
    Delim = Replace(Delim, "X-MS-Exchange-CrossTenant-OriginalArrivalTime:", "~X-MS-Exchange-CrossTenant-OriginalArrivalTime:")
    Delim = Replace(Delim, "X-MS-Exchange-CrossTenant-FromEntityHeader:", "~X-MS-Exchange-CrossTenant-FromEntityHeader:")
    Delim = Replace(Delim, "X-MS-Exchange-CrossTenant-Id:", "~X-MS-Exchange-CrossTenant-Id:")
    Delim = Replace(Delim, "X-MS-Exchange-CrossTenant-Network-Message-Id:", "~X-MS-Exchange-CrossTenant-Network-Message-Id:")
    Delim = Replace(Delim, "X-MS-Exchange-Transport-CrossTenantHeadersStamped:", "~X-MS-Exchange-Transport-CrossTenantHeadersStamped:")
    Delim = Replace(Delim, "X-MS-Exchange-Transport-EndToEndLatency:", "~X-MS-Exchange-Transport-EndToEndLatency:")
    Delim = Replace(Delim, "X-MS-Exchange-Processed-By-BccFoldering:", "~X-MS-Exchange-Processed-By-BccFoldering:")
    Delim = Replace(Delim, "X-Microsoft-Antispam-Mailbox-Delivery:", "~X-Microsoft-Antispam-Mailbox-Delivery:")
    Delim = Replace(Delim, "X-Microsoft-Antispam-Message-Info:", "~X-Microsoft-Antispam-Message-Info:")

    ' Split Header String Into Array
    Arr = Split(Delim, "~")
    ReDim ArrRet(0 To 58, 0 To 2)
    For i = LBound(Arr) To UBound(Arr)
        If Arr(i) > "" Then
            ' Split Property Name/ Value
            Arr2 = Split(Arr(i), ":")
            PropertyName = Arr2(0)
            PropertyValue = Arr2(1)
            ArrRet(i, 0) = i
            ArrRet(i, 1) = PropertyName
            ArrRet(i, 2) = PropertyValue

        End If
    Next
   ParseEmailHeader = ArrRet
End Function