サブフォルダ用のOutlookの電子メールの抽出方法

Question

このように、この優雅なマクロがOutlook（OfficeTricks.comにある）から電子メールを取得するために見つかりました。

しかし、それはサブフォルダの1つの層だけ下に行くようです。私はこれをサブフォルダの2〜3層にすることができる方法はありますか？

例えば

Option Explicit 
'This Code is Downloaded from OfficeTricks.com 
'Visit this site for more such Free Code 
Sub VBA_Export_Outlook_Emails_To_Excel() 
    'Add Tools->References->"Microsoft Outlook nn.n Object Library" 
    'nn.n varies as per our Outlook Installation 
    Dim Folder As Outlook.MAPIFolder 
    Dim sFolders As Outlook.MAPIFolder 
    Dim iRow As Integer, oRow As Integer 
    Dim MailBoxName As String, Pst_Folder_Name As String 

    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session) 
    MailBoxName = "Clauric@ABC.com" 

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session) 
    Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items" 

    'To directly a Folder at a high level 
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name) 

    'To access a main folder or a subfolder (level-1) 
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders 
     If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found 
     For Each sFolders In Folder.Folders 
      If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then 
       Set Folder = sFolders 
       GoTo Label_Folder_Found 
      End If 
     Next sFolders 
    Next Folder 

Label_Folder_Found: 
    If Folder.Name = "" Then 
     MsgBox "Invalid Data in Input" 
     GoTo End_Lbl1: 
    End If 

    'Read Through each Mail and export the details to Excel for Email Archival 
    ThisWorkbook.Sheets(1).Activate 
    Folder.Items.Sort "Received" 

    'Insert Column Headers 
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender" 
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject" 
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date" 
    ThisWorkbook.Sheets(1).Cells(1, 4) = "Size" 
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID" 
    ThisWorkbook.Sheets(1).Cells(1, 6) = "Body" 

    'Export eMail Data from PST Folder to Excel with date and time 
    oRow = 1 
    For iRow = 1 To Folder.Items.Count 
     'If condition to import mails received in last 60 days 
     'To import all emails, comment or remove this IF condition 
     If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then 
      oRow = oRow + 1 
      ThisWorkbook.Sheets(1).Cells(oRow, 1).Select 
      ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName 
      ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject 
      ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime 
      ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size 
      ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress 
      ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body 
     End If 
    Next iRow 
    MsgBox "Outlook Mails Extracted to Excel" 
    Set Folder = Nothing 
    Set sFolders = Nothing 

End_Lbl1: 
End Sub 

私がダウンして、フォルダ1層にPst_Folder_Nameを変更しようと、 Pst_Folder_Name = "Operations"、それは動作します。 オブジェクト変数またはWithブロック変数が

を設定していない：私はそのようPst_Folder_Name = "Manufacturing"、またはPst_Folder_Name = "Operations/Manufacturing"などの操作のサブフォルダを、しようとした場合しかし、私は

実行時エラーメッセージ「91」を得ますIf Folder.Name = "" Then

Answer 1

再帰を探しているのではなく、ツリー内の深いフォルダを手動で参照する場合。

必要な数だけ追加してください。

'To access a subfolder (level-1) or a subfolder (level-2) 
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders 
    If VBA.UCase(Folder.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then GoTo Label_Folder_Found 
    For Each sFolders In Folder.Folders 
     If VBA.UCase(sFolders.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then 
      Set Folder = sFolders 
      GoTo Label_Folder_Found 
     End If 
    Next sFolders 
Next Folder 

'To access a subfolder (level-2) or a subfolder (level-3) 
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders(Oneleveldeeper_Folder_Name).Folders 
    If VBA.UCase(Folder.Name) = VBA.UCase(Twolevelsdeeper_Folder_Name) Then GoTo Label_Folder_Found 
    For Each sFolders In Folder.Folders 
     If VBA.UCase(sFolders.Name) = VBA.UCase(Twolevelsdeeper_Folder_Name) Then 
      Set Folder = sFolders 
      GoTo Label_Folder_Found 
     End If 
    Next sFolders 
Next Folder