凶残的Outlook VBA Script: Outlook VBA Script that gets info on currently selected email using various Property

Option Explicit

‘ VBA Script that gets info on the currently selected email using propertyAccessor and various syntaxes
‘ (see other scripts at http://www.GregThatcher.com for other ways to get email properties)
‘ Property Tag Syntax looks like this http://schemas.microsoft.com/mapi/proptag/0x0005000b
‘ Property Tag Syntax is used for Outlook ‘Properties‘ (defined by Outlook Object Model)
‘
‘ Property ID Syntax looks like this http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8586001f
‘ Property ID Syntax is used for MAPI Named Properties (optional Outlook properties that can‘t be deleted) and UserProperties (properties you can add which are visible to the user)
‘
‘ Named Property Syntax looks like this http://schemas.microsoft.com/mapi/string folloowed by a property name
‘ Named Property Syntax is used to create and view ‘Named Properties" (properties you can create, but which are not visible to the user)
‘
‘ Office document syntax looks like this: urn:schemas-microsoft-com:office:outlook#source-table-label
‘
‘ 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 -- there is no propertyAccessor)
‘
‘ To find the DASL definition of Outlook Properties, use the method described in Professional Outlook 2007 Programming (Programmer to Programmer) by Ken Slovak
‘ From the ‘Views‘ menu, create a new view (but don‘t save it)
‘ Click on the ‘Advanced‘ tab, and choose ‘Filter‘
‘ Choose a Field from the ‘Field‘ dropdown, also choose a condition and value
‘ Click on the ‘Sql tab‘
‘ Check the ‘Edit these Criteria‘ checkbox
‘

Public Sub GetCurrentMailInfoUsingpropertyAccessor()
    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
    Dim stringArray() As String
    Dim index
    Dim currentString
    Dim tempVal
    
    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("Auto Forwarded", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0005000b")) & vbCrLf
            report = report & AddToReportIfNotBlank("Bcc", propertyAccessor.GetProperty("urn:schemas:calendar:resources")) & vbCrLf
            report = report & AddToReportIfNotBlank("Billing Information", propertyAccessor.GetProperty("urn:schemas:contacts:billinginformation")) & vbCrLf
            stringArray() = propertyAccessor.GetProperty("urn:schemas-microsoft-com:office:office#Keywords")
            For index = LBound(stringArray) To UBound(stringArray)
                report = report & "Categories (" & index & ") " & stringArray(index) & vbCrLf
            Next index
            report = report & AddToReportIfNotBlank("Cc", propertyAccessor.GetProperty("urn:schemas:httpmail:displaycc")) & vbCrLf
            report = report & AddToReportIfNotBlank("Changed By", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3ffa001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Contacts", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8586001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Conversation", propertyAccessor.GetProperty("urn:schemas:httpmail:thread-topic")) & vbCrLf
            report = report & AddToReportIfNotBlank("Created", propertyAccessor.GetProperty("urn:schemas:calendar:created")) & vbCrLf
            report = report & AddToReportIfNotBlank("Defer Until", propertyAccessor.GetProperty("http://schemas.microsoft.com/exchange/deferred-delivery-iso")) & vbCrLf
            report = report & AddToReportIfNotBlank("Do Not AutoArchive", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/850e000b")) & vbCrLf

            report = report & AddToReportIfNotBlank("Due Date", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81050040")) & vbCrLf
            report = report & AddToReportIfNotBlank("E-mail Account", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8580001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Expires", propertyAccessor.GetProperty("urn:schemas:mailheader:expiry-date")) & vbCrLf
            report = report & AddToReportIfNotBlank("Flag Complated Date", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10910040")) & vbCrLf
            report = report & AddToReportIfNotBlank("Flag Status", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10900003")) & vbCrLf
            report = report & AddToReportIfNotBlank("Follow Up Flag", propertyAccessor.GetProperty("urn:schemas:httpmail:messageflag")) & vbCrLf
            report = report & AddToReportIfNotBlank("From", propertyAccessor.GetProperty("urn:schemas:httpmail:fromname")) & vbCrLf
            report = report & AddToReportIfNotBlank("Have Replies Sent To", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0050001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("IMAP Status", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85700003")) & vbCrLf
            report = report & AddToReportIfNotBlank("Importance", propertyAccessor.GetProperty("urn:schemas:httpmail:importance")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("In Folder", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0e05001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("InfoPath Form Type", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85b1001f")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("Message", propertyAccessor.GetProperty("urn:schemas:httpmail:textdescription")) & vbCrLf
            report = report & AddToReportIfNotBlank("Message Class", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x001a001e")) & vbCrLf
            report = report & AddToReportIfNotBlank("Mileage", propertyAccessor.GetProperty("http://schemas.microsoft.com/exchange/mileage")) & vbCrLf
            report = report & AddToReportIfNotBlank("Modified", propertyAccessor.GetProperty("DAV:getlastmodified")) & vbCrLf
            report = report & AddToReportIfNotBlank("Originator Delivery Requested", propertyAccessor.GetProperty("http://schemas.microsoft.com/exchange/deliveryreportrequested")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("Outlook Data File", propertyAccessor.GetProperty("urn:schemas-microsoft-com:office:outlook#source-table-label")) & vbCrLf
            report = report & AddToReportIfNotBlank("Outlook Internal Version", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85520003")) & vbCrLf
            report = report & AddToReportIfNotBlank("Outlook Version", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8554001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Receipt Requested", propertyAccessor.GetProperty("http://schemas.microsoft.com/exchange/readreceiptrequested")) & vbCrLf
            report = report & AddToReportIfNotBlank("Received", propertyAccessor.GetProperty("urn:schemas:httpmail:datereceived")) & vbCrLf
            report = report & AddToReportIfNotBlank("Received Representing Name", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0044001f")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("Recipient Name", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/received_by_name")) & vbCrLf
            report = report & AddToReportIfNotBlank("Relevance", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10840003")) & vbCrLf
            report = report & AddToReportIfNotBlank("Reminder", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8503000b")) & vbCrLf
            report = report & AddToReportIfNotBlank("Remote Status", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85110003")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("Retrieval Time", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062014-0000-0000-C000-000000000046}/8f040003")) & vbCrLf
            ‘report = report & AddToReportIfNotBlank("RSS Feed", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062041-0000-0000-C000-000000000046}/8904001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Sensitivity", propertyAccessor.GetProperty("http://schemas.microsoft.com/exchange/sensitivity-long")) & vbCrLf
            report = report & AddToReportIfNotBlank("Sent", propertyAccessor.GetProperty("urn:schemas:httpmail:date")) & vbCrLf
            report = report & AddToReportIfNotBlank("Signed By", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00020328-0000-0000-C000-000000000046}/9104001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("Start Date", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81040040")) & vbCrLf
            report = report & AddToReportIfNotBlank("Subject", propertyAccessor.GetProperty("urn:schemas:httpmail:subject")) & vbCrLf
            report = report & AddToReportIfNotBlank("Task Subject", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85a4001f")) & vbCrLf
            report = report & AddToReportIfNotBlank("To", propertyAccessor.GetProperty("urn:schemas:httpmail:displayto")) & vbCrLf
            report = report & AddToReportIfNotBlank("Tracking Status", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{0006200B-0000-0000-C000-000000000046}/88090003")) & vbCrLf
            report = report & AddToReportIfNotBlank("Voting Response", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8524001f")) & vbCrLf
           
        End If
    Next
    
    Call CreateReportAsEmail("Email properties from PropertyAccessor using various Property Syntaxes", report)
End Sub


Private Function AddToReportIfNotBlank(FieldName As String, FieldValue)
    AddToReportIfNotBlank = ""
    If (IsNull(FieldValue) Or 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