VBA를 사용하여 PR_TRANSPORT_MESSAGE_HEADERS에서 이메일 주소를 가져 오는 방법

Question

VBA를 사용하여 PR_TRANSPORT_MESSAGE_HEADERS에서 전자 메일 주소를 얻으려면 어떻게해야합니까?

정규 표현식을 시도해 본 적이 있지만 문제가 없는데 문제가 있습니다. "받는 사람 :"및 "부터"및 "CC"

Answer 1

매크로 아래 나는 새로운 메일 항목의 속성을 조사 할 때마다 더 큰 얻을

나는에서 전자 메일 주소를 검색 할 필요가있다. 새 속성 또는 속성을 추가하고 오늘 필요하지 않은 것들을 주석 처리하고 관련 이메일 몇 개를 선택하고 매크로를 실행합니다. 내 여가 시간에 데스크톱 파일 "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