使用以下代码循环遍历Outlook电子邮件的每个子文件夹时出现问题：
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
'Set objFolder = ActiveExplorer.CurrentFolder
Set objFolder = Session.GetFolderFromID (Application.ActiveExplorer.CurrentFolder.EntryID)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
' MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oStartDate As String
Dim oEndDate As String
Set dict = CreateObject("Scripting.Dictionary")
oStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
oEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oStartDate & "' And [Received] <= '" & oEndDate & "'")
myItems.SetColumns ("Categories")
' date for mssg:
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output for days
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
代码在收件箱本身上运行，但它并没有深入到子文件夹中。 我一直试图正确地循环它，但我一直在失败。 谢谢你的帮助！
答案 0 :(得分：0)
ProcessFolder中的代码会为父文件夹中的每个子文件夹调用自身。
Option Explicit
Private MessageText As String
Public Sub ListAllFolders()
'Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
'''''''''''''''''''''''''''''''''''''''''
'No need to reference the Outlook application as the code
'is running from within the application itself.
''''''''''''''''''''''''''''''''''''''''
'Set oOutlook = GetObject(, "Outlook.Application")
'Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set nNameSpace = GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
ProcessFolder mFolderSelected
MsgBox MessageText
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
'Get the folder name and count of items.
MessageText = MessageText & oParent.Name & ": " & oParent.Items.Count & vbCr
'If there are subfolders then process them as well.
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
End Sub
修改
这是我用来计算所选文件夹中不同类别的电子邮件的代码。子文件夹。
它按日期和类别分割计数：
Public Sub CreateReport()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim oItem As Object
Dim rLastCell As Range
Dim x As Long
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
''''''''''''''''''''''''''''''''
'Clear Sheet of existing data. '
''''''''''''''''''''''''''''''''
shtAnalysis.Cells.Delete Shift:=xlUp
ProcessFolder mFolderSelected
''''''''''''''''''''''''''
'Tidy up and add totals. '
''''''''''''''''''''''''''
Set rLastCell = LastCell(shtAnalysis)
ThisWorkbook.Activate
MsgBox "Complete", vbOKOnly
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
Dim PropertyAccessor As Object
Dim v As Variant
On Error Resume Next
For Each oMail In oParent.Items
PlaceDetails oMail
Next oMail
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
On Error GoTo 0
End Sub
Sub PlaceDetails(oMailItem As Object)
Dim rFoundCell As Range
Dim lColumn As Long
Dim lRow As Long
'''''''''''''''''''''''''''''''''''''''''''''
'Only process emails containing a category. '
'''''''''''''''''''''''''''''''''''''''''''''
If oMailItem.categories <> "" Then
With shtAnalysis
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Does the category already exist on the spreadsheet? '
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Rows("1:1").Cells.Find(What:=oMailItem.categories, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lColumn = rFoundCell.Column
Else
lColumn = LastCell(shtAnalysis).Column + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Next find the row by looking for sent on date in column A. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Columns("A:A").Cells.Find(What:=Int(oMailItem.senton), After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lRow = rFoundCell.Row
Else
lRow = LastCell(shtAnalysis).Row + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''
'Place category, date and count on the sheet. '
'''''''''''''''''''''''''''''''''''''''''''''''
.Cells(lRow, 1).Value = Int(oMailItem.senton)
.Cells(1, lColumn).Value = oMailItem.categories
If .Cells(lRow, lColumn) = "" Then
.Cells(lRow, lColumn).NumberFormat = "General"
.Cells(lRow, lColumn) = 1
Else
.Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
End If
End With
End If
End Sub
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function