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

该代码示例首先使用当前Application.Session的{{3}}属性获取当前会话的所有存储。

对于该会话的每个商店，它使用NameSpace.Stores来获取位于商店根目录的文件夹。

对于每个商店的根文件夹，它反复调用EnumerateFolders过程，直到它访问并显示了树中每个文件夹的名称为止。

如何将多个子文件夹的类别计数从Outlook导出到Excel

1 个答案: