Outlook extract folders with e-mails inside them to local hard drive

问题

Let's say I have a ton of folders which represent different categories of e-mails in Outlook. Each folder has at least one thousand e-mails. There's a high number of folders too.

If I want to copy to the hard drive the folders with the exact names and files inside, it does not let me.

I have to manually create a folder on the hard drive for each folder in Outlook and then copy all the e-mails within that folder.

Any way to do this faster? Any VBA coding solution?

回答1:

Use FileSystemObject to check or create folders locally from Outlook vba

    Path = "C:\Temp\"
    If Not FSO.FolderExists(Path) Then
        FSO.CreateFolder (Path)
    End If

---

You can also loop through to get Outlook folders, FolderPath and all their contents count then use Mid and InStr to find position and folder name..

Here is quick vba Example, I'm using Subject-line as save name and Regex.Replace to strip Invalid Characters from Subject-line.

---

Option Explicit
Public Sub Example()
    Dim Folders As New Collection
    Dim EntryID As New Collection
    Dim StoreID As New Collection
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim olNs As NameSpace
    Dim Item As MailItem
    Dim RegExp As Object
    Dim FSO As Object

    Dim FolderPath As String
    Dim Subject As String
    Dim FileName As String
    Dim Fldr As String
    Dim Path As String

    Dim Pos As Long
    Dim ii As Long
    Dim i As Long


    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set RegExp = CreateObject("vbscript.regexp")

    Path = "C:\Temp\"

    Call GetFolder(Folders, EntryID, StoreID, Inbox)

    For i = 1 To Folders.Count
        DoEvents
        Fldr = Folders(i)

        Pos = InStr(3, Fldr, "\") + 1
            Fldr = Mid(Fldr, Pos)

        FolderPath = Path & Fldr & "\"
        Debug.Print FolderPath

        If Not FSO.FolderExists(FolderPath) Then
            FSO.CreateFolder (FolderPath)
        End If

      Set SubFolder = Application.Session.GetFolderFromID(EntryID(i), StoreID(i))

        For ii = 1 To SubFolder.Items.Count
                DoEvents
            Set Item = SubFolder.Items(ii)

            ' Replace invalid characters with empty strings.
            With RegExp
                .Pattern = "[^\w\.@-]"
                .IgnoreCase = True
                .Global = True
            End With

            Subject = RegExp.Replace(Item.Subject, " ")

            FileName = FolderPath & Subject & ".msg"
            Item.SaveAs FileName, olMsg

        Next ii
    Next i

End Sub

Private Function GetFolder( _
        Folders As Collection, _
        EntryID As Collection, _
        StoreID As Collection, _
        Folder As MAPIFolder _
)
    Dim SubFolder As MAPIFolder
        Folders.Add Folder.FolderPath
        EntryID.Add Folder.EntryID
        StoreID.Add Folder.StoreID

        For Each SubFolder In Folder.Folders
            GetFolder Folders, EntryID, StoreID, SubFolder
            Debug.Print SubFolder.Name ' Immediate Window
        Next SubFolder

        Set SubFolder = Nothing

End Function

来源：https://stackoverflow.com/questions/41730984/outlook-extract-folders-with-e-mails-inside-them-to-local-hard-drive