Using VBscript to list all the messages in all the folders

  • Thread starter Thread starter Mario
  • Start date Start date
M

Mario

I need to write a VBscript script to recursively list the titles of all the
messages in all the folders in Outlook 2000.

Where can I find a working sample to start from?

Given the user uses more different .pst files, how can I select a specific
..pst file (or all the open .pst files)?

Mario
 
The NameSpace.Folders collection contains the folder hierarchies for every
loaded store (Exchange mailbox, .psts), so that's a good place to start.

Below is a bunch of sample code to help you do what you want:

1) This code creates an array (strPaths) containing the full path to every
folder in every loaded store:

Option Explicit
Dim i As Integer
Dim strPaths() As String
Dim myNS As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim colFolders As Folders
Dim colFolders2 As Folders

Sub Run()
Set myNS = Application.GetNamespace("MAPI")
Set colFolders = myNS.Folders
RecurseFolders colFolders
End Sub

Sub RecurseFolders(objTheseFolders As Outlook.Folders)
For Each myFolder In objTheseFolders
Debug.Print myFolder.Name
ReDim Preserve strPaths(i + 1)
strPaths(i) = myFolder.FolderPath
Set colFolders2 = myFolder.Folders
i = i + 1
RecurseFolders colFolders2
Next
End Sub

2) This procedure returns a MAPIFolder object, given a full folder path:

'******************************************************************************
'Custom procedure: OpenMAPIFolder(ByVal strPath)
'Purpose: Return a MAPIFolder from Path argument
'Returns: MAPIFolder objec
'******************************************************************************
Function OpenMAPIFolder(ByVal strPath) As Outlook.MAPIFolder
Dim objFldr As MAPIFolder
Dim strDir As String
Dim strName As String
Dim i As Integer
On Error Resume Next
If Left(strPath, Len("\")) = "\" Then
strPath = Mid(strPath, Len("\") + 1)
Else
Set objFldr = m_olApp.ActiveExplorer.CurrentFolder
End If
While strPath <> ""
i = InStr(strPath, "\")
If i Then
strDir = Left(strPath, i - 1)
strPath = Mid(strPath, i + Len("\"))
Else
strDir = strPath
strPath = ""
End If
If objFldr Is Nothing Then
Set objFldr = m_olApp.GetNamespace("MAPI").Folders(strDir)
On Error GoTo 0
Else
Set objFldr = objFldr.Folders(strDir)
End If
Wend
Set OpenMAPIFolder = objFldr
End Function

3) This procedure outputs the Subject line of every e-mail message in the
given folder (and all-subjfoldes) to the Immediate window in your VBA Editor:

Sub GetAllEmailSubjectInFolderAndSubFolders(objCurrentFolder As
Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders, objItems As Outlook.Items
Dim objItem As Object


'FIND ALL E-MAIL MESSAGES IN THE CURRENT FOLDER
Set objItems = objCurrentFolder.Items
For Each objItem In objItems
If objItem.Class = olMail Then
Debug.Print "Message subject = " & objItem.Subject
End If
Next

For Each objCurrentFolder In objCurrentFolder.Folders
If objCurrentFolder.DefaultItemType = olMailItem Then
ParseSubFolders objCurrentFolder
End If
Next
End Sub

Hope this helps!
 
Thank you very much

Mario

Eric Legault said:
The NameSpace.Folders collection contains the folder hierarchies for every
loaded store (Exchange mailbox, .psts), so that's a good place to start.

Below is a bunch of sample code to help you do what you want:

1) This code creates an array (strPaths) containing the full path to
every
folder in every loaded store:

Option Explicit
Dim i As Integer
Dim strPaths() As String
Dim myNS As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim colFolders As Folders
Dim colFolders2 As Folders

Sub Run()
Set myNS = Application.GetNamespace("MAPI")
Set colFolders = myNS.Folders
RecurseFolders colFolders
End Sub

Sub RecurseFolders(objTheseFolders As Outlook.Folders)
For Each myFolder In objTheseFolders
Debug.Print myFolder.Name
ReDim Preserve strPaths(i + 1)
strPaths(i) = myFolder.FolderPath
Set colFolders2 = myFolder.Folders
i = i + 1
RecurseFolders colFolders2
Next
End Sub

2) This procedure returns a MAPIFolder object, given a full folder path:

'******************************************************************************
'Custom procedure: OpenMAPIFolder(ByVal strPath)
'Purpose: Return a MAPIFolder from Path argument
'Returns: MAPIFolder object
'******************************************************************************
Function OpenMAPIFolder(ByVal strPath) As Outlook.MAPIFolder
Dim objFldr As MAPIFolder
Dim strDir As String
Dim strName As String
Dim i As Integer
On Error Resume Next
If Left(strPath, Len("\")) = "\" Then
strPath = Mid(strPath, Len("\") + 1)
Else
Set objFldr = m_olApp.ActiveExplorer.CurrentFolder
End If
While strPath <> ""
i = InStr(strPath, "\")
If i Then
strDir = Left(strPath, i - 1)
strPath = Mid(strPath, i + Len("\"))
Else
strDir = strPath
strPath = ""
End If
If objFldr Is Nothing Then
Set objFldr = m_olApp.GetNamespace("MAPI").Folders(strDir)
On Error GoTo 0
Else
Set objFldr = objFldr.Folders(strDir)
End If
Wend
Set OpenMAPIFolder = objFldr
End Function

3) This procedure outputs the Subject line of every e-mail message in the
given folder (and all-subjfoldes) to the Immediate window in your VBA
Editor:

Sub GetAllEmailSubjectInFolderAndSubFolders(objCurrentFolder As
Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders, objItems As Outlook.Items
Dim objItem As Object


'FIND ALL E-MAIL MESSAGES IN THE CURRENT FOLDER
Set objItems = objCurrentFolder.Items
For Each objItem In objItems
If objItem.Class = olMail Then
Debug.Print "Message subject = " & objItem.Subject
End If
Next

For Each objCurrentFolder In objCurrentFolder.Folders
If objCurrentFolder.DefaultItemType = olMailItem Then
ParseSubFolders objCurrentFolder
End If
Next
End Sub

Hope this helps!
Click to expand...
 
Back
Top