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示例，我使用主题行作为保存名称，使用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

Outlook将包含电子邮件的文件夹解压缩到本地硬盘

1 个答案: