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
适用于:Outlook 2007 以上。
转自: http://www.gregthatcher.com/Scripts/VBA/Outlook/GetEmailInfoUsingPropertyAccessor.aspx