Save emails in folder and subfolders

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.

Code:

---

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:

Code:

---

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.

Anyone have any thoughts on this?

Put a

Code:

---

Debug.Print StrFolderPath

---

line before the errant line to see what the path is.

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.

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

Code:

---

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

---

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

Code:

---

Debug.Print StrFolderPath

---

didn't show anything.

When I changed it to

Code:

---

MsgBox(StrFolderPath)

---

it displayed the correct path that I selected.

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

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

Code:

---

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

---

Thank you! That worked perfectly.