Consulting

Results 1 to 8 of 8

Thread: Save emails in folder and subfolders

  1. #1
    VBAX Regular
    Joined
    Oct 2021
    Posts
    9
    Location

    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.

    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.

  2. #2
    VBAX Regular
    Joined
    Oct 2021
    Posts
    9
    Location
    Anyone have any thoughts on this?

  3. #3
    Put a
    Debug.Print StrFolderPath
    line before the errant line to see what the path is.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    VBAX Regular
    Joined
    Oct 2021
    Posts
    9
    Location
    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.

  5. #5
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    VBAX Regular
    Joined
    Oct 2021
    Posts
    9
    Location
    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 SaveAllEmails.zipattached a Zip file containing a Word document with the full code.

  7. #7
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  8. #8
    VBAX Regular
    Joined
    Oct 2021
    Posts
    9
    Location
    Thank you! That worked perfectly.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •