Outlookは、ローカルのハードドライブに電子メールを含むフォルダを抽出します

Question

Outlookでさまざまな電子メールのカテゴリを表す多数のフォルダがあります。各フォルダには少なくとも1000個の電子メールがあります。フォルダ数も多いです。

正確な名前とファイルが入っているフォルダをハードドライブにコピーしたい場合は、私には許可されません。

Outlookの各フォルダのハードドライブに手動でフォルダを作成し、そのフォルダ内のすべての電子メールをコピーする必要があります。

これを行うにはどんな方法がありますか？任意のVBAコーディングソリューション？

Answer 1

使用FileSystemObjectオブジェクトを確認したり、OutlookのVBAからローカルフォルダを作成

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

---

あなたはまた、ループスルーは、FolderPathをOutlookフォルダを取得することができ、そのすべての内容は位置を見つけるために、ミッドと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