Outlook VBA Script that gets info on currently selected email using Property Tag Syntax


Option Explicit

' VBA Script that gets info on the currently selected email using 'Property Tag Syntax'
' (see other scripts a http://www.GregThatcher.com for other ways to get email properties)
' Property Tag Syntax is used for Outlook Properties (defined by Outlook Object Model)
' as opposed to Named Mapi Properties (defined by Outlook, but only exist if Outlook has added that property to the item of interest)
' or UserProperties (visible to users, and can be added dynamically to an item) or Named Properties (not visible users, can be added dynamically)
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com
' THIS SCRIPT WILL ONLY RUN ON OUTLOOK 2007 OR LATER (it won't work on Outlook 2003)

' Types of Properties
Const PT_BOOLEAN As String = "000B"
Const PT_BINARY As String = "0102"
Const PT_MV_BINARY As String = "1102"
Const PT_DOUBLE As String = "0005"
Const PT_LONG As String = "0003"
Const PT_OBJECT As String = "000D"
Const PT_STRING8 As String = "001E"
Const PT_MV_STRING8 As String = "101E"
Const PT_SYSTIME As String = "0040"
Const PT_UNICODE As String = "001F"
Const PT_MV_UNICODE As String = "101F"

Public Sub GetCurrentMailInfoUsingPropertyTagSyntax()
    Dim Session As Outlook.NameSpace
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim currentItem As Object
    Dim currentMail As MailItem
    Dim report As String
    Dim propertyAccessor As Outlook.PropertyAccessor
    
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
    
    'for all items do...
    For Each currentItem In Selection
        If currentItem.Class = olMail Then
            Set currentMail = currentItem
            
            Set propertyAccessor = currentMail.PropertyAccessor
    
            report = report & AddToReportIfNotBlank("PR_MESSAGE_CLASS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x001A" & PT_STRING8)) & vbCrLf
    
            report = report & AddToReportIfNotBlank("PR_SUBJECT", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0037" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_CLIENT_SUBMIT_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0039" & PT_SYSTIME)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENT_REPRESENTING_SEARCH_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003B" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SUBJECT_PREFIX PT_STRING8", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003D" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_RECEIVED_BY_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003F" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_RECEIVED_BY_NAME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0040" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENT_REPRESENTING_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0041" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENT_REPRESENTING_NAME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0042" & PT_STRING8)) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_REPLY_RECIPIENT_ENTRIES", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x004F" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_REPLY_RECIPIENT_NAMES", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0050" & PT_STRING8)) & vbCrLf
    
            report = report & AddToReportIfNotBlank("PR_RECEIVED_BY_SEARCH_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0051" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENT_REPRESENTING_ADDRTYPE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0064" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENT_REPRESENTING_EMAIL_ADDRESS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_CONVERSATION_TOPIC", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0070" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_CONVERSATION_INDEX", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0071" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_RECEIVED_BY_ADDRTYPE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0075" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_RECEIVED_BY_EMAIL_ADDRESS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0076" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_TRANSPORT_MESSAGE_HEADERS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENDER_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C19" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENDER_NAME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1A" & PT_STRING8)) & vbCrLf
    
            report = report & AddToReportIfNotBlank("PR_SENDER_SEARCH_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1D" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENDER_ADDRTYPE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1E" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SENDER_EMAIL_ADDRESS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_DISPLAY_BCC", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E02" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_DISPLAY_CC", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E03" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_DISPLAY_TO", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_MESSAGE_DELIVERY_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E06" & PT_SYSTIME)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_MESSAGE_FLAGS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E07" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_MESSAGE_SIZE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E08" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_PARENT_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E09" & PT_BINARY))) & vbCrLf
    
            'report = report & AddToReportIfNotBlank("PR_MESSAGE_RECIPIENTS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E12" & PT_OBJECT)) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_MESSAGE_ATTACHMENTS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E13" & PT_OBJECT)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_HASATTACH", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1B" & PT_BOOLEAN)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_NORMALIZED_SUBJECT", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1D" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_RTF_IN_SYNC", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1F" & PT_BOOLEAN)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_PRIMARY_SEND_ACCT", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E28" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_NEXT_SEND_ACCT", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E29" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_ACCESS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF4" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_ACCESS_LEVEL", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF7" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_MAPPING_SIGNATURE", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF8" & PT_BINARY))) & vbCrLf
    
            report = report & AddToReportIfNotBlank("PR_RECORD_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF9" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_STORE_RECORD_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFA" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_STORE_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFB" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_OBJECT_TYPE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFE" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_ENTRYID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFF" & PT_BINARY))) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_BODY", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1000" & PT_STRING8)) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_RTF_COMPRESSED", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1009" & PT_BINARY))) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_HTML", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1013" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_INTERNET_MESSAGE_ID", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035" & PT_STRING8)) & vbCrLf
            'report = report & AddToReportIfNotBlank("PR_LIST_UNSUBSCRIBE", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1045" & PT_STRING8)) & vbCrLf
    
            'report = report & AddToReportIfNotBlank("N/A", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1046" & PT_STRING8)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_CREATION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3007" & PT_SYSTIME)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_LAST_MODIFICATION_TIME", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3008" & PT_SYSTIME)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_SEARCH_KEY", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x300B" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_STORE_SUPPORT_MASK", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x340D" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("N/A", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x340F" & PT_LONG)) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_MDB_PROVIDER", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3414" & PT_BINARY))) & vbCrLf
            report = report & AddToReportIfNotBlank("PR_INTERNET_CPID", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3FDE" & PT_LONG)) & vbCrLf
            'report = report & AddToReportIfNotBlank("SideEffects", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x8005" & PT_LONG)) & vbCrLf
            'report = report & AddToReportIfNotBlank("InetAcctID", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x802A" & PT_STRING8)) & vbCrLf
            'report = report & AddToReportIfNotBlank("InetAcctName", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x804F" & PT_STRING8)) & vbCrLf
            'report = report & AddToReportIfNotBlank("RemoteEID", propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x8066" & PT_BINARY))) & vbCrLf
            'report = report & AddToReportIfNotBlank("x-rcpt-to", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x80AD" & PT_STRING8)) & vbCrLf

            
        End If
    Next
    
    Call CreateReportAsEmail("Email properties from PropertyAccessor using Property Tag Syntax", report)
End Sub


Private Function AddToReportIfNotBlank(FieldName As String, FieldValue As String)
    AddToReportIfNotBlank = ""
    If (FieldValue <> "") Then
        AddToReportIfNotBlank = FieldName & " : " & FieldValue & vbCrLf
    End If
    
End Function

' VBA SubRoutine which displays a report inside an email
' Programming by Greg Thatcher, http://www.GregThatcher.com
Public Sub CreateReportAsEmail(Title As String, report As String)
    On Error GoTo On_Error

    Dim Session As Outlook.NameSpace
    Dim mail As MailItem
    Dim MyAddress As AddressEntry
    Dim Inbox

    Set Session = Application.Session
    Set Inbox = Session.GetDefaultFolder(olFolderInbox)
    Set mail = Inbox.Items.Add("IPM.Mail")

    mail.Subject = Title
    mail.Body = report

    mail.Save
    mail.Display
    

Exiting:
        Set Session = Nothing
        Exit Sub

On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub



Problems, Comments, Suggestions? Click here to contact Greg Thatcher
Please read my Disclaimer





Copyright (c) 2013 Thatcher Development Software, LLC. All rights reserved. No claim to original U.S. Gov't works.