将电子邮件从多个文件夹提取到本地硬盘同名文件夹

Question

我有代表不同类别的 Outlook 电子邮件的文件夹。

我想将电子邮件复制到具有相同 Outlook 文件夹名称的硬盘文件夹中。

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

Answer 1

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

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

---

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

这是快速 vba 示例，我使用主题行作为保存名称，并使用 Regex.Replace 从主题行中删除无效字符。

---

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