Click here to Skip to main content
15,672,517 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, "YYYY-MM-DD_hh.mm")
            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
  
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, "")
      
ExitFunction:
    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
      
ExitSub:
    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
      
ExitFunction:
    Set objShell = Nothing
      
End Function
Posted
Comments
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