Question

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

我一直在尝试一些正则表达式，但我从来没有使用它，我遇到了一些问题。

我需要从＆＃34; To：＆＃34;中检索电子邮件地址。和＆＃34;来自：＆＃34;和＆＃34; CC：＆＃34;

Answer 1

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

我添加了所有与您的要求相关的“非标准”属性。大多数似乎与“标准属性”重复。唯一有用的是PR_TRANSPORT_MESSAGE_HEADERS的“To：”行。电子邮件地址已从标准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

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

1 个答案: