Click here to Skip to main content
15,920,596 members
Please Sign up or sign in to vote.
1.00/5 (1 vote)
See more:
The Following code has been written in VBA for MS Outlook to save all emails in a specific folder on Outlook (for example inbox, sent items, etc.) as .msg files in a directory on the user's desktop. However, it does not function correctly for sub-folders on Outlook. For example, if the user has already created a sub-folder within the inbox folder or any other default folders in Outlook, the code will not run correctly. Could anyone help me revise the code so that it can function well for any folder on MS Outlook? Any help would be appreciated.

What I have tried:

Option Explicit
       Dim StrSavePath     As String

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 StrFolder       As String
    Dim StrSaveFolder   As String
    Dim strFolderpath   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
BrowseForFolder StrSavePath
    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 = Format(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
End Sub
Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
    Set RegX = Nothing
End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
    Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder '  As Folder

Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Desktop\")
StrSavePath = objFolder.self.Path

    On Error Resume Next
    On Error GoTo 0
    Set objShell = Nothing
End Function
Member 15627495 5-Mar-23 4:54am    
MS outlook already have a function to 'backup' all emails, and have a 'register key' about location for saving all emails,
why don't you use those tools and paths as 'base'?

About Paths :
paths can be 'relative' or 'system', you have to retrieve the full path before processing a true copy..
Richard MacCutchan 5-Mar-23 8:14am    
"the code will not run correctly"
What exactly does that mean?
CHill60 8-Mar-23 5:23am    
I ran your code against my InBox in Outlook under which I have several sub-folders and some of those have sub-folders. It worked. So what is your actual problem?

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

CodeProject, 20 Bay Street, 11th Floor Toronto, Ontario, Canada M5J 2N8 +1 (416) 849-8900