Option Explicit

Dim StrSavePath     As String

Sub sfSaveAllEmails()

    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 oaOutlook       As Outlook.Application

    Dim mapiSubFolder   As MAPIFolder

    Dim mItem           As MailItem

    Dim FSO             As Object

    Dim objActualFolder As Object

    Dim colFolders      As New Collection

    Dim colEntryID      As New Collection

    Dim colStoreID      As New Collection

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set oaOutlook = Outlook.Application

    Set iNameSpace = oaOutlook.GetNamespace("MAPI")

    Set objActualFolder = iNameSpace.PickFolder

    If objActualFolder Is Nothing Then

        GoTo ExitSub:

    End If

    StrSavePath = "c:\temp\mail\"

    Call GetFolder(colFolders, colEntryID, colStoreID, objActualFolder)

    For i = 1 To colFolders.count

        StrFolder = fRemoveIlegalChars(colFolders(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 mapiSubFolder = oaOutlook.Session.GetFolderFromID(colEntryID(i), colStoreID(i))

        On Error Resume Next

        For j = 1 To mapiSubFolder.Items.count

            Set mItem = mapiSubFolder.Items(j)

            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")

            StrSubject = mItem.Subject

            StrName = fRemoveIlegalChars(StrSubject)

            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"

            StrFile = Left(StrFile, 256)

            mItem.SaveAs StrFile, 3

            DoEvents

        Next j

        On Error GoTo 0

    Next i

    

    MsgBox "Done!"

ExitSub:

End Sub

Function fRemoveIlegalChars(StrInput)

    Dim RegEx As Object ' Using REGular EXPresion to remove ilegal chars

    Set RegEx = CreateObject("vbscript.regexp")

    RegEx.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"

    RegEx.IgnoreCase = True

    RegEx.Global = True

    fRemoveIlegalChars = RegEx.Replace(StrInput, "") ' If an ilegal char is in the title, is removed

    Set RegEx = Nothing ' Free Pointer

End Function

Sub GetFolder(colFolders As Collection, colEntryID As Collection, colStoreID As Collection, Fld As MAPIFolder)

    Dim mapiSubFolder As MAPIFolder ' MAPIFolder is deprecated, but still working, I'll need to change to Folder

    colFolders.Add Fld.FolderPath

    colEntryID.Add Fld.EntryID

    colStoreID.Add Fld.StoreID

    

    For Each mapiSubFolder In Fld.colFolders

        GetFolder colFolders, colEntryID, colStoreID, mapiSubFolder

    Next mapiSubFolder

    Set mapiSubFolder = Nothing ' Free Pointer

End Sub

'Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String

'    Dim objShell As Object

'    Dim objFolder '  As Folder

'    Dim strEnvironm As String

'

'    strEnvironm = "c:\temp\" ' CStr(strEnvironmn("USERPROFILE")) ' Do not use, cause problems because is mixing english (MyDocuments) and Spanish (Documentos)

'    Set objShell = CreateObject("Shell.Application")

'    Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, strEnvironm)

'    StrSavePath = objFolder.self.Path

'

'    On Error Resume Next

'    On Error GoTo 0

'

'    Set objShell = Nothing

'End Function