Option Explicit
' VBA Script that gets info on the currently selected email using the Outlook Object Model
' (see other scripts a http://www.GregThatcher.com for other ways to get email properties)
' 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
Public Sub GetCurrentEmailInfo()
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 currentAction As Action
Dim currentConflict As Conflict
Dim currentLink As Link
Dim currentRecipient As Recipient
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
report = report & AddToReportIfNotBlank("EntryID: ", currentMail.entryID) & vbCrLf
report = report & "Actions: " & vbCrLf
For Each currentAction In currentMail.Actions
report = report & vbTab & currentAction.Name & vbCrLf
Next
report = report & vbCrLf
report = report & AddToReportIfNotBlank("AlternateRecipientAllowed: ", currentMail.AlternateRecipientAllowed)
report = report & AddToReportIfNotBlank("Application: ", currentMail.Application.Name)
report = report & AddToReportIfNotBlank("AutoForwarded: ", currentMail.AutoForwarded)
report = report & AddToReportIfNotBlank("AutoResolvedWinner: ", currentMail.AutoResolvedWinner)
report = report & AddToReportIfNotBlank("BCC: ", currentMail.BCC)
report = report & AddToReportIfNotBlank("BillingInformation: ", currentMail.BillingInformation)
report = report & AddToReportIfNotBlank("BodyFormat: ", currentMail.BodyFormat)
report = report & AddToReportIfNotBlank("Categories: ", currentMail.Categories)
report = report & AddToReportIfNotBlank("CC: ", currentMail.CC)
report = report & AddToReportIfNotBlank("Class: ", currentMail.Application.Class)
report = report & AddToReportIfNotBlank("Companies: ", currentMail.Companies)
If currentMail.Conflicts.Count > 0 Then
report = report & "Conflicts: " & vbCrLf
For Each currentConflict In currentMail.Conflicts
report = report & vbTab & currentConflict.Name & vbCrLf
Next
report = report & vbCrLf
End If
report = report & AddToReportIfNotBlank("ConversationIndex: ", currentMail.ConversationIndex)
report = report & AddToReportIfNotBlank("ConversationTopic: ", currentMail.ConversationTopic)
report = report & AddToReportIfNotBlank("CreationTime: ", currentMail.CreationTime)
report = report & AddToReportIfNotBlank("DeferredDeliveryTime: ", currentMail.DeferredDeliveryTime)
report = report & AddToReportIfNotBlank("DeleteAfterSubmit: ", currentMail.DeleteAfterSubmit)
report = report & AddToReportIfNotBlank("DownloadState: ", currentMail.DownloadState)
report = report & AddToReportIfNotBlank("Entry ID: ", currentMail.entryID)
report = report & AddToReportIfNotBlank("ExpiryTime: ", currentMail.ExpiryTime)
report = report & AddToReportIfNotBlank("FlagRequest: ", currentMail.FlagRequest)
report = report & AddToReportIfNotBlank("FormDescription: ", currentMail.FormDescription)
report = report & AddToReportIfNotBlank("Importance: ", currentMail.Importance)
report = report & AddToReportIfNotBlank("InternetCodepage: ", currentMail.InternetCodepage)
report = report & AddToReportIfNotBlank("IsConflict: ", currentMail.IsConflict)
' Not available for Outlook 2003
'report = report & AddToReportIfNotBlank("IsMarkedAsTask: ", currentMail.IsMarkedAsTask)
'report = report & AddToReportIfNotBlank("LastModificationTime: ", currentMail.ItemProperties)
report = report & AddToReportIfNotBlank("LastModificationTime: ", currentMail.LastModificationTime)
If currentMail.Links.Count > 0 Then
report = report & "Links: " & vbCrLf
For Each currentLink In currentMail.Links
report = report & vbTab & currentLink.Name & vbCrLf
Next
report = report & vbCrLf
End If
report = report & AddToReportIfNotBlank("MarkForDownload: ", currentMail.MarkForDownload)
report = report & AddToReportIfNotBlank("MessageClass: ", currentMail.MessageClass)
report = report & AddToReportIfNotBlank("Mileage: ", currentMail.Mileage)
report = report & AddToReportIfNotBlank("NoAging: ", currentMail.NoAging)
report = report & AddToReportIfNotBlank("OriginatorDeliveryReportRequested: ", currentMail.OriginatorDeliveryReportRequested)
report = report & AddToReportIfNotBlank("OutlookInternalVersion: ", currentMail.OutlookInternalVersion)
report = report & AddToReportIfNotBlank("OutlookVersion: ", currentMail.OutlookVersion)
report = report & AddToReportIfNotBlank("Permission: ", currentMail.Permission)
report = report & AddToReportIfNotBlank("PermissionService: ", currentMail.PermissionService)
'report = report & AddToReportIfNotBlank("Permission: ", currentMail.PropertyAccessor)
report = report & AddToReportIfNotBlank("ReadReceiptRequested: ", currentMail.ReadReceiptRequested)
'report = report & AddToReportIfNotBlank("ReceivedByEntryID: ", currentMail.ReceivedByEntryID)
report = report & AddToReportIfNotBlank("ReceivedByName: ", currentMail.ReceivedByName)
'report = report & AddToReportIfNotBlank("ReceivedOnBehalfOfEntryID: ", currentMail.ReceivedOnBehalfOfEntryID)
report = report & AddToReportIfNotBlank("ReceivedOnBehalfOfName: ", currentMail.ReceivedOnBehalfOfName)
report = report & AddToReportIfNotBlank("ReceivedTime: ", currentMail.ReceivedTime)
report = report & AddToReportIfNotBlank("RecipientReassignmentProhibited: ", currentMail.RecipientReassignmentProhibited)
report = report & "Recipients: " & vbCrLf
For Each currentRecipient In currentMail.Recipients
report = report & vbTab & "Name: " & currentRecipient.Name & vbCrLf
report = report & vbTab & vbTab & "Address: " & currentRecipient.Address & vbCrLf
report = report & vbTab & vbTab & "AddressEntry: " & currentRecipient.AddressEntry & vbCrLf
report = report & vbTab & vbTab & "AutoResponse: " & currentRecipient.AutoResponse & vbCrLf
report = report & vbTab & vbTab & "Class: " & currentRecipient.Class & vbCrLf
report = report & vbTab & vbTab & "DisplayType: " & currentRecipient.DisplayType & vbCrLf
report = report & vbTab & vbTab & "EntryID: " & currentRecipient.entryID & vbCrLf
report = report & vbTab & vbTab & "Index: " & currentRecipient.Index & vbCrLf
report = report & vbTab & vbTab & "MeetingResponseStatus: " & currentRecipient.MeetingResponseStatus & vbCrLf
'report = report & vbTab & vbTab & "Parent: " & currentRecipient.Parent & vbCrLf
'report = report & vbTab & vbTab & "PropertyAccessor: " & currentRecipient.PropertyAccessor & vbCrLf
report = report & vbTab & vbTab & "Resolved: " & currentRecipient.Resolved & vbCrLf
'report = report & vbTab & vbTab & "Session: " & currentRecipient.Session & vbCrLf
report = report & vbTab & vbTab & "TrackingStatus: " & currentRecipient.TrackingStatus & vbCrLf
report = report & vbTab & vbTab & "TrackingStatusTime: " & currentRecipient.TrackingStatusTime & vbCrLf
report = report & vbTab & vbTab & "Type: " & currentRecipient.Type & vbCrLf
Next
report = report & vbCrLf
report = report & AddToReportIfNotBlank("ReminderOverrideDefault: ", currentMail.ReminderOverrideDefault)
report = report & AddToReportIfNotBlank("ReminderPlaySound: ", currentMail.ReminderPlaySound)
report = report & AddToReportIfNotBlank("ReminderSet: ", currentMail.ReminderSet)
report = report & AddToReportIfNotBlank("ReminderSoundFile: ", currentMail.ReminderSoundFile)
report = report & AddToReportIfNotBlank("ReminderTime: ", currentMail.ReminderTime)
report = report & AddToReportIfNotBlank("ReminderTime: ", currentMail.RemoteStatus)
report = report & AddToReportIfNotBlank("ReplyRecipientNames: ", currentMail.ReplyRecipientNames)
If currentMail.ReplyRecipients.Count > 0 Then
report = report & "ReplyRecipients: " & vbCrLf
For Each currentRecipient In currentMail.ReplyRecipients
report = report & vbTab & "Name: " & currentRecipient.Name & vbCrLf
report = report & vbTab & vbTab & "Address: " & currentRecipient.Address & vbCrLf
report = report & vbTab & vbTab & "AddressEntry: " & currentRecipient.AddressEntry & vbCrLf
report = report & vbTab & vbTab & "AutoResponse: " & currentRecipient.AutoResponse & vbCrLf
report = report & vbTab & vbTab & "Class: " & currentRecipient.Class & vbCrLf
report = report & vbTab & vbTab & "DisplayType: " & currentRecipient.DisplayType & vbCrLf
report = report & vbTab & vbTab & "EntryID: " & currentRecipient.entryID & vbCrLf
report = report & vbTab & vbTab & "Index: " & currentRecipient.Index & vbCrLf
report = report & vbTab & vbTab & "MeetingResponseStatus: " & currentRecipient.MeetingResponseStatus & vbCrLf
'report = report & vbTab & vbTab & "Parent: " & currentRecipient.Parent & vbCrLf
'report = report & vbTab & vbTab & "PropertyAccessor: " & currentRecipient.PropertyAccessor & vbCrLf
report = report & vbTab & vbTab & "Resolved: " & currentRecipient.Resolved & vbCrLf
'report = report & vbTab & vbTab & "Session: " & currentRecipient.Session & vbCrLf
report = report & vbTab & vbTab & "TrackingStatus: " & currentRecipient.TrackingStatus & vbCrLf
report = report & vbTab & vbTab & "TrackingStatusTime: " & currentRecipient.TrackingStatusTime & vbCrLf
report = report & vbTab & vbTab & "Type: " & currentRecipient.Type & vbCrLf
Next
report = report & vbCrLf
End If
report = report & AddToReportIfNotBlank("Saved: ", currentMail.Saved)
report = report & AddToReportIfNotBlank("Subject: ", currentMail.Subject)
report = report & AddToReportIfNotBlank("Submitted: ", currentMail.Submitted)
' Not Available for Outlook 2003
'report = report & AddToReportIfNotBlank("TaskCompletedDate: ", currentMail.TaskCompletedDate)
' Not Available for Outlook 2003
'report = report & AddToReportIfNotBlank("TaskDueDate: ", currentMail.TaskDueDate)
' Not Available for Outlook 2003
'report = report & AddToReportIfNotBlank("TaskStartDate: ", currentMail.TaskStartDate)
' Not Available for Outlook 2003
'report = report & AddToReportIfNotBlank("TaskSubject: ", currentMail.TaskSubject)
report = report & AddToReportIfNotBlank("To: ", currentMail.To)
' Not Available for Outlook 2003
' report = report & AddToReportIfNotBlank("ToDoTaskOrdinal: ", currentMail.ToDoTaskOrdinal)
report = report & AddToReportIfNotBlank("UnRead: ", currentMail.UnRead)
'report = report & AddToReportIfNotBlank("UserProperties: ", currentMail.UserProperties)
report = report & AddToReportIfNotBlank("VotingOptions: ", currentMail.VotingOptions)
report = report & AddToReportIfNotBlank("VotingResponse: ", currentMail.VotingResponse)
report = report & vbCrLf
report = report & vbCrLf
report = report & "Body: " & vbCrLf
report = report & currentMail.Body & vbCrLf
report = report & vbCrLf
report = report & vbCrLf
report = report & "HTML Body: " & vbCrLf
report = report & currentMail.HTMLBody & vbCrLf
report = report & vbCrLf
report = report & vbCrLf
report = report & vbCrLf
report = report & vbCrLf
End If
Next
Call CreateReportAsEmail("Current Email Report", 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
|
|