时间戳

首页 > 解决方案 > 从 Excel 循环浏览 Outlook 文件夹和子文件夹

vba - 从 Excel 循环浏览 Outlook 文件夹和子文件夹

问题描述

我想按类别将多个文件夹的计数从 Outlook 导出到 Excel。

我尝试使用 For...Loop，但它循环当前文件夹而不是循环子文件夹。

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

我可以成功地按类别导出特定文件夹的计数，但无法为多个文件夹执行此操作。

标签： vbaoutlook

解决方案

示例代码为会话枚举所有商店中的所有文件夹：

 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过程，直到它访问并显示该树中每个文件夹的名称。

推荐阅读