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他們所有的內容計數，然後使用中秋節和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