如何使用VBA从PR_TRANSPORT_MESSAGE_HEADERS获取电子邮件地址

每当我要调查新的邮件项目属性时，下面的宏都会变大。我添加一个或多个新属性，注释掉我今天不需要的那些属性，选择一些相关的电子邮件并运行宏。然后，我可以在闲暇时检查桌面文件“ DemoExplorer.txt”。

我添加了所有与您的需求相关的“非标准”属性。多数似乎与“标准特性”重复。似乎唯一有用的是PR_TRANSPORT_MESSAGE_HEADERS的“ To：”行。电子邮件地址已从标准的“收件人”属性中删除，但它们显示在“收件人：”行中。

希望这可以帮助。

Public Sub DemoExplorer()

  ' Outputs selected properties of selected emails to a file.

  ' ???????  No record of when originally coded
  ' 22Oct16  Output to desktop file rather than Immediate Window.
  ' Various  New properties added as necessary

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283

  ' Source of PropertyAccessor information:
  ' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/

  ' Needs reference to Microsoft Scripting Runtime if "TextStream"
  ' and "FileSystemObject" are to be recognised

  Dim AttachCount As Long
  Dim AttachType As Long
  Dim FileOut As TextStream
  Dim Fso As FileSystemObject
  Dim Exp As Outlook.Explorer
  Dim InxA As Long
  Dim InxR As Long
  Dim ItemCrnt As MailItem
  Dim NumSelected As Long
  Dim Path As String
  Dim PropAccess As Outlook.propertyAccessor

  Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")

  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set FileOut = Fso.CreateTextFile(Path & "\DemoExplorer.txt", True)

  Set Exp = Outlook.Application.ActiveExplorer

  NumSelected = Exp.Selection.Count

  If NumSelected = 0 Then
    Debug.Print "No emails selected"
  Else
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        FileOut.WriteLine "--------------------------"
        FileOut.WriteLine "From (Sender): " & .Sender
        FileOut.WriteLine "From (Sender name): " & .SenderName
        FileOut.WriteLine "From (Sender email address): " & .SenderEmailAddress
        FileOut.WriteLine "Subject: " & CStr(.Subject)
        FileOut.WriteLine "Received: " & Format(.ReceivedTime, "dMMMyy h:mm:ss")
        FileOut.WriteLine "To: " & .To
        FileOut.WriteLine "CC: " & .CC
        FileOut.WriteLine "Recipients: " & .Recipients(1)
        For InxR = 2 To .Recipients.Count
          FileOut.WriteLine Space(12) & .Recipients(InxR)
        Next
        'FileOut.WriteLine "Text: " & Replace(Replace(Replace(.Body, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
        'FileOut.WriteLine "Html: " & Replace(Replace(Replace(.HtmlBody, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
        'AttachCount = .Attachments.Count
        'FileOut.WriteLine "Number of attachments: " & AttachCount
        'For InxA = 1 To AttachCount
        '  AttachType = .Attachments(InxA).Type
        '  FileOut.WriteLine "Attachment " & InxA
        '  FileOut.Write "  Attachment type: "
        '  Select Case AttachType
        '    Case olByValue
        '      FileOut.WriteLine "By value"
        '    Case olEmbeddeditem
        '      FileOut.WriteLine "Embedded item"
        '    Case olByReference
        '      FileOut.WriteLine "By reference"
        '    Case olOLE
        '      FileOut.WriteLine "OLE"
        '    Case Else
        '      FileOut.WriteLine "Unknown " & AttachType
        '  End Select
        '  ' I recall PathName giving an error for some types
        '  On Error Resume Next
        '  FileOut.WriteLine "  Path: " & .Attachments(InxA).PathName
        '  On Error GoTo 0
        '  FileOut.WriteLine "  File name: " & .Attachments(InxA).FileName
        '  FileOut.WriteLine "  Display name: " & .Attachments(InxA).DisplayName
        '  ' I do not recall every seeing a parent but it is listed as a property
        '  ' but for some attachment types it gives an error
        '  On Error Resume Next
        '  FileOut.WriteLine "  Parent: " & .Attachments(InxA).Parent
        '  On Error GoTo 0
        '  FileOut.WriteLine "  Position: " & .Attachments(InxA).Position
        'Next

        Set PropAccess = .propertyAccessor

        FileOut.WriteLine "PR_RECEIVED_BY_NAME: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0040001E")
        FileOut.WriteLine "PR_SENT_REPRESENTING_NAME: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0042001E")
        FileOut.WriteLine "PR_REPLY_RECIPIENT_NAMES: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0050001E")
        FileOut.WriteLine "PR_SENT_REPRESENTING_EMAIL_ADDRESS: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001E")
        FileOut.WriteLine "PR_RECEIVED_BY_EMAIL_ADDRESS: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0076001E")
        FileOut.WriteLine "PR_TRANSPORT_MESSAGE_HEADERS:" & vbLf & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
        FileOut.WriteLine "PR_SENDER_NAME: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1A001E")
        FileOut.WriteLine "PR_SENDER_EMAIL_ADDRESS: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
        FileOut.WriteLine "PR_DISPLAY_BCC: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E02001E")
        FileOut.WriteLine "PR_DISPLAY_CC: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E03001E")
        FileOut.WriteLine "PR_DISPLAY_TO: " & _
                           PropAccess.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")

        Set PropAccess = Nothing
      End With
    Next
  End If

  FileOut.Close

End Sub