VBA Script that gets list of all Outlook Items (Emails, Contacts, Tasks, etc.)
Option Explicit
' VBA Script to get list of All Emails
' 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
' Uses new "Table" Object (available in Outlook 2007 and later -- won't work in Outlook 2003)
Public Sub GetListOfEmails()
On Error GoTo On_Error
Dim Session As Outlook.NameSpace
Dim Report As String
Dim Folders As Outlook.Folders
Dim Folder As Outlook.Folder
Dim reply As Integer
Set Session = Application.Session
reply = MsgBox(Prompt:="This could take a VERY long time, and you won't be able to use Outlook while it runs -- are you sure you want to list all emails from all folders?", _
Buttons:=vbYesNoCancel, Title:="Run Long Macro")
If reply = vbYes Then
Set Folders = Session.Folders
' Call RecurseFolders(Folders(1), vbTab, Report)
For Each Folder In Folders
Call RecurseFolders(Folder, vbTab, Report)
Report = Report & "---------------------------------------------------------------------------" & vbCrLf
Next
Else
reply = MsgBox(Prompt:="Would you like to just list all emails from your Inbox?", _
Buttons:=vbYesNoCancel, Title:="Run Long Macro")
If reply = vbYes Then
Call RecurseFolders(Session.GetDefaultFolder(olFolderInbox), vbTab, Report)
Else
Exit Sub
End If
End If
Dim retValue As Boolean
retValue = CreateReportAsEmail("List of Emails", Report)
Exiting:
Set Session = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Private Sub RecurseFolders(CurrentFolder As Outlook.Folder, Tabs, Report As String)
Dim Table As Outlook.Table
Dim Row As Outlook.Row
Dim rowValues() As Variant
Dim SubFolders As Outlook.Folders
Dim SubFolder As Outlook.Folder
Report = Report & "Folder Name: " & CurrentFolder.Name & " (Store: " & CurrentFolder.Store.DisplayName & ")" & vbCrLf
Set Table = CurrentFolder.GetTable
Do While Table.EndOfTable = False
Set Row = Table.GetNextRow
rowValues = Row.GetValues
Report = Report & Tabs
Report = Report & "Subject: " & rowValues(1)
Report = Report & vbTab & "MessageClass: " & rowValues(4)
' Report = Report & vbTab & "Creation Time: " & rowValues(2)
Report = Report & vbTab & "Last Modification Time: " & rowValues(3)
'Report = Report & vbTab & "EntryID: " & rowValues(0)
Report = Report & vbCrLf
Loop
Set SubFolders = CurrentFolder.Folders
For Each SubFolder In SubFolders
Call RecurseFolders(SubFolder, Tabs & vbTab, Report)
Next SubFolder
End Sub
' VBA Function which displays a report inside an email
Public Function 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 As Outlook.Folder
CreateReportAsEmail = True
Set Session = Application.Session
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set mail = Inbox.Items.Add("IPM.Mail")
Set MyAddress = Session.CurrentUser.AddressEntry
mail.Recipients.Add (MyAddress.Address)
mail.Recipients.ResolveAll
mail.Subject = Title
mail.Body = Report
mail.Save
mail.Display
Exiting:
Set Session = Nothing
Exit Function
On_Error:
CreateReportAsEmail = False
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Function
|