Outlook 将其中包含电子邮件的文件夹提取到本地硬盘

Question

假设我有大量文件夹，代表 Outlook 中不同类别的电子邮件。每个文件夹至少有一千封电子邮件。也有很多文件夹。

如果我想将具有确切名称的文件夹和里面的文件复制到硬盘，它不让我这样做。

我必须在硬盘上为 Outlook 中的每个文件夹手动创建一个文件夹，然后复制该文件夹中的所有电子邮件。

有什么方法可以更快地做到这一点？任何 VBA 编码解决方案？

Answer 1

使用 FileSystemObject 从 Outlook 在本地检查或创建文件夹vba

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

您还可以循环获取 Outlook 文件夹，FolderPath 及其所有内容计数，然后使用 Mid 和 InStr 查找位置和文件夹名称..

这是快速 vba 示例，我使用 Subject-line 作为保存名称，并使用 Regex.Replace 从 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

Outlook 将其中包含电子邮件的文件夹提取到本地硬盘

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

regex

vba

outlook

outlook-2010