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

  • Thread starter Thread starter Hubert
  • Start date Start date
H

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
 
Thanks Alan & Michael, your suggestion enabled me to pass the initial error
but now i get this error:

"Run -time error:
Could not open the item. Try again "

And the following line is highlighted in Debug :

"For Each olkSubFolder In olkFolder.Folders"
 
Hubert

If you debug the error can you find out which folder it is trying to iterate
through? I would think that you don't have permission to access a folder
somewhere along the lines.
 
The macro actually works :
Now in XP pro, when i run the code, I still get the error but the
outlook.txt file is populated with the outlook folders ( despite the
errror )
In Vista Business, the code works w/ no issues so i'm not sure what gives ??
The only thing is that one needs to be loged in as administrator for the
code to work otherwise the "permission denied" error pops out. Thank you
Alan for your help..
 
Back
Top