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.