Как экспортировать счетчик по категориям для нескольких подпапок из outlook в excel

Question

Я хотел бы экспортировать счетчик по категориям для нескольких папок из outlook в excel.

Я пытался использовать функцию For ... Loop Function, но, как оказалось, продолжайте зацикливать текущие папки, а не зацикливать другие подпапки.

Sub CategoriesEmails()

    Dim oFolder As MAPIFolder
    Dim oDict As Object
    Dim sStartDate As String
    Dim sEndDate As String
    Dim oItems As Outlook.Items
    Dim sStr As String
    Dim sMsg As String
    Dim strFldr As String
    Dim OutMail As Object
    Dim xlApp As Object

    On Error Resume Next
    Set oFolder = Application.ActiveExplorer.CurrentFolder

    Set oDict = CreateObject("Scripting.Dictionary")

    sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
    sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")

    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
    oItems.SetColumns ("Categories")

    For Each aItem In oItems
    sStr = aItem.Categories
    If Not oDict.Exists(sStr) Then
    oDict(sStr) = 0
    End If
    oDict(sStr) = CLng(oDict(sStr)) + 1
    Next aItem

    sMsg = ""
    For Each aKey In oDict.Keys
    sMsg = sMsg & aKey & ":   " & oDict(aKey) & vbCrLf
    Next
    MsgBox sMsg

    strFldr = ""
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True
    xlApp.Workbooks.Open strFldr & "CountByCategories.xlsx"
    xlApp.Sheets("Sheet1").Select
    For Each aKey In oDict.Keys

    xlApp.Range("A1") = "Folder Name"
    xlApp.Range("A1").Font.Bold = True

    xlApp.Range("B1") = "Category"
    xlApp.Range("B1").Font.Bold = True
    xlApp.Range("C1") = "Count"
    xlApp.Range("C1").Font.Bold = True

    xlApp.Range("D1") = "Start Date"
    xlApp.Range("D1").Font.Bold = True
    xlApp.Range("E1") = "End Date"
    xlApp.Range("E1").Font.Bold = True

    xlApp.Range("A2").Offset(i, 0).Value = oFolder
    xlApp.Range("B2").Offset(i, 0).Value = aKey
    xlApp.Range("C2").Offset(i, 0).Value = oDict(aKey) & vbCrLf
    xlApp.Range("D2").Offset(i, 0).Value = sStartDate
    xlApp.Range("E2").Offset(i, 0).Value = sEndDate
    i = i + 1
    Next
    xlApp.Save

    Set oFolder = Nothing
End Sub

Я мог бы успешно экспортировать счет по категориямдля определенной папки, но не удается сделать это для нескольких папок, запустив следующий код.Что я должен делать?Я был бы очень признателен, если бы вы могли мне помочь.Большое спасибо!

Answer 1

Пример кода перечисляет все папки во всех хранилищах для сеанса:

 Sub EnumerateFoldersInStores() 
  Dim colStores As Outlook.Stores 
  Dim oStore As Outlook.Store 
  Dim oRoot As Outlook.Folder  

  On Error Resume Next 
  Set colStores = Application.Session.Stores 
  For Each oStore In colStores 
   Set oRoot = oStore.GetRootFolder 
   Debug.Print (oRoot.FolderPath) 
   EnumerateFolders oRoot 
  Next 
 End Sub 

 Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder) 
  Dim folders As Outlook.folders 
  Dim Folder As Outlook.Folder 
  Dim foldercount As Integer 

  On Error Resume Next 
  Set folders = oFolder.folders 
  foldercount = folders.Count 
  'Check if there are any folders below oFolder 
  If foldercount Then 
   For Each Folder In folders 

    ' here you can call your function to gather all categories from a folder
    ' Sub CategoriesEmails(Folder)

    Debug.Print (Folder.FolderPath) 

    EnumerateFolders Folder 
  Next 
 End If 
End Sub

Пример кода начинается с получения всех хранилищ для текущего сеанса с использованием свойства NameSpace.Stores текущего Application.Session.

Для каждого хранилища этого сеанса он использует Store.GetRootFolder для получения папки в корне хранилища.

Длякорневая папка каждого хранилища, она итеративно вызывает процедуру EnumerateFolders, пока не посетит и не отобразит имя каждой папки в этом дереве.