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
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