Save emails in folder and subfolders

[LVG8R]

I am trying to save emails in a particular folder to a folder on my computer. I want to be able to keep the subfolder structure and I would like the code to prompt which folder on my computer to save to.

I have the following code but keep getting a "Run-time error '76': Path not found" error.


Sub SaveAllEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i

ExitSub:

End Sub


When I run the debugger it highlights the line:


FSO.CreateFolder (StrFolderPath)

I thought that code should create the required folder.

The rest of the code seems to be functions correctly. I get prompted for the Outlook folder I want to save the emails from and I get prompted for the folder on my computer to save to.

I left out the code for the functions and another sub because I kept getting errors posting the full code. I can add them if needed.

Anyone have any suggestions?

Thank you.

[LVG8R]

Anyone have any thoughts on this?

[gmayor]

Put a
Debug.Print StrFolderPathline before the errant line to see what the path is.

[LVG8R]

I put a msgbox line in the code and it returns the correct path. There appears to be something wrong with the FileSystemObject code. I have made sure to add the Microsoft Scripting Runtime reference library.

I am still at a loss.

[gmayor]

You have not posted all the relevant code so it can't be tested, however if the FileSystemObject was the problem, it would have failed when it was declared. My guess is that the issue relates to the path itself, hence my original question. May I suggest that you call the following code to create the path


Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.createfolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

[LVG8R]

I cannot post the full code. I get an error message stating:

"Post denied. New posts are limited by number of URLs it may contain and checked if it doesn't contain forbidden words."


Debug.Print StrFolderPath didn't show anything.

When I changed it to
MsgBox(StrFolderPath) it displayed the correct path that I selected.

I have 29558attached a Zip file containing a Word document with the full code.

[gmayor]

If you add the sub I last posted and change the main macro as follows, the code appears to work. The issue appears to be that the original is unable to create more than one folder deep. The sub I posted will create any missing path


Sub SaveAllEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

CreateFolders StrFolderPath

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
DoEvents
Next j
DoEvents
On Error GoTo 0
Next i

ExitSub:

End Sub

[LVG8R]

Thank you! That worked perfectly.