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


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.