Outlook VBA получает адрес псевдонима от Outlook. Получатели

Question

Перепишите объяснение: Мы используем Office 365 Outlook Exchange в нашей компании. В настоящее время у нас есть много различных электронных писем, связанных с клиентами, которые имеют свои собственные отдельные учетные записи. Например, support@google.com, sales@google.com, customerservice@google.com и т. Д. Чтобы сэкономить средства, возникла идея, что вместо того, чтобы платить за все эти различные аккаунты, связанные с клиентами, вместо этого мы создаем псевдонимы электронной почты для каждого из них. из них в один аккаунт, т.е. tasks@google.com.

Это должно прекрасно работать, однако большая проблема, с которой мы сталкиваемся, заключается в том, что адрес электронной почты Outlook.Recipient всегда показывает tasks@google.com. Это не говорит мне, кто клиент на самом деле пытался по электронной почте. Мне нужно знать, какой псевдоним клиент пытался отправить по электронной почте.

Вот пример кода, который я использую, чтобы попытаться извлечь псевдоним ... но вместо этого он возвращает адрес электронной почты действительного аккаунта, т.е. задачи@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

Основная проблема с @TonyDallimore помогла мне решить как принятый ответ выше. Однако мне все еще нужно было получить свойство получателя из заголовка. Следующий код - это то, что я придумал в сочетании с кодом Тони плюс моя собственная функция синтаксического анализа. Он разбирает полный заголовок письма в массив.

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

Answer 2

Это может помочь.

Выберите несколько таких писем, а затем запустите следующий макрос, который будет выводить весь заголовок SMTP для каждого выбранного письма.

Обратите внимание, что Immediate Window имеет ограничение около 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