Trying to run this macro to save Outlook mailbox folder list - but it doesn't work
 

I found this code on the net. It suppose to copy a user mailbox folder list
to a .txt file( the one you see in the left pane ). When I run it, i get an
error :

"Runtime error 429: ActiveX component cannot create object "
and " Set objCDO = CreateObject("MAPI.Session") " is highlighted in yellow.
Can anyone see why i get this error. Maybe there is a simpler way to save
Outlook mail folder list to a file. btw, i'm running this off Outlook 2007
in the exchange setup. Any tips/advice would be appreciated.



Dim objFile As Object

Sub EnumerateOutlookFolderStructure()
Dim objCDO As Object, _
objStore As Object, _
objFSO As Object, _
olkFolder As Outlook.MAPIFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Change the file name and path on the follwoing line as desired
Set objFile = objFSO.CreateTextFile("C:\Outlook.txt", True)
Set objCDO = CreateObject("MAPI.Session")
'Change the profile name as needed
objCDO.Logon "new"
For Each objStore In objCDO.InfoStores
objFile.WriteLine objStore.Name
Set olkFolder = OpenMAPIFolder("\" & objStore.Name)
EnumerateSubFolders olkFolder, 1
Next
objCDO.Logoff
Set objCDO = Nothing
Set objStore = Nothing
Set objFSO = Nothing
Set olkFolder = Nothing
objFile.Close
Set objFile = Nothing
MsgBox "All done!"
End Sub

Sub EnumerateSubFolders(olkFolder As Outlook.MAPIFolder, intLevel As
Integer)
Dim olkSubFolder As Outlook.MAPIFolder
For Each olkSubFolder In olkFolder.Folders
objFile.WriteLine Space(intLevel * 2) & olkSubFolder.Name
EnumerateSubFolders olkSubFolder, intLevel + 1
Next
Set olkSubFolder = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine. I found it somewhere on the internet but do
'not remember where or who the author is. The original author(s) deserves
all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, I
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath ""
I = InStr(szPath, "\")
If I Then
szDir = Left(szPath, I - 1)
szPath = Mid(szPath, I + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function

Trying to run this macro to save Outlook mailbox folder list - but it doesn't work
 

You'd need to install the CDO 1.21 library on your computer. But instead you
could also rewrite the code and use Outlook objects instead of CDO. Here's
an example for how to loop recursively through the folder using Outlook
objects:

http://www.vboffice.net/sample.html?...cmd=showite m

--
Best regards
Michael Bauer - MVP Outlook

: Outlook Categories? Category Manager Is Your Tool
: VBOffice Reporter for Data Analysis & Reporting
: http://www.vboffice.net/product.html?pub=6&lang=en


Am Wed, 19 Nov 2008 15:52:20 -0500 schrieb Hubert:

I found this code on the net. It suppose to copy a user mailbox folder
list
to a .txt file( the one you see in the left pane ). When I run it, i get
an
error :

"Runtime error 429: ActiveX component cannot create object "
and " Set objCDO = CreateObject("MAPI.Session") " is highlighted in
yellow.
Can anyone see why i get this error. Maybe there is a simpler way to save
Outlook mail folder list to a file. btw, i'm running this off Outlook 2007
in the exchange setup. Any tips/advice would be appreciated.



Dim objFile As Object

Sub EnumerateOutlookFolderStructure()
Dim objCDO As Object, _
objStore As Object, _
objFSO As Object, _
olkFolder As Outlook.MAPIFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Change the file name and path on the follwoing line as desired
Set objFile = objFSO.CreateTextFile("C:\Outlook.txt", True)
Set objCDO = CreateObject("MAPI.Session")
'Change the profile name as needed
objCDO.Logon "new"
For Each objStore In objCDO.InfoStores
objFile.WriteLine objStore.Name
Set olkFolder = OpenMAPIFolder("\" & objStore.Name)
EnumerateSubFolders olkFolder, 1
Next
objCDO.Logoff
Set objCDO = Nothing
Set objStore = Nothing
Set objFSO = Nothing
Set olkFolder = Nothing
objFile.Close
Set objFile = Nothing
MsgBox "All done!"
End Sub

Sub EnumerateSubFolders(olkFolder As Outlook.MAPIFolder, intLevel As
Integer)
Dim olkSubFolder As Outlook.MAPIFolder
For Each olkSubFolder In olkFolder.Folders
objFile.WriteLine Space(intLevel * 2) & olkSubFolder.Name
EnumerateSubFolders olkSubFolder, intLevel + 1
Next
Set olkSubFolder = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine. I found it somewhere on the internet but do
'not remember where or who the author is. The original author(s) deserves
all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, I
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath ""
I = InStr(szPath, "\")
If I Then
szDir = Left(szPath, I - 1)
szPath = Mid(szPath, I + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function