我提供了一种解决方案，可单击一个文件夹并返回该文件夹中包含多少个项目。
现在，他们询问是否可以保留该退货，并通过单击主文件夹中的子文件夹将其细分。
示例：
INBOX具有3个子文件夹：Folder1，Folder2，Folder3
INBOX包含3封电子邮件，其中每个子文件夹一封电子邮件。
从而：
INBOX总数：3
文件夹1总计：1
文件夹2合计：1
Folder3总计：1
我创建了一个循环，将主文件夹中包含的所有子文件夹放入数组中。
我的下一个想法是将其转换为字典，在其中将包含的项预设为0。然后，使用循环构成字典后，我目前正在使用该函数检查日期范围内是否有东西，以便查看它所属的“文件夹”，并在字典（关联数组）中将我预先设置为零的值加1，以进行“匹配”
下面是我尝试过的事情：
Sub Countemailsperday()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim ODate As String
Dim ODate2 As String
Dim dict As Dictionary
Set dict = New Dictionary
Dim coll As New Collection
Dim oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
' Dim Dict As Scripting.Dictionary
ODate = InputBox("Start Date? (format YYYY-MM-DD")
ODate2 = InputBox("End Date? (format YYYY-MM-DD")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Application.ActiveExplorer.CurrentFolder
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 ssitem As MailItem
Dim dateStr As String
Dim numholder As Integer
Dim myItems As Outlook.Items
'Dim dict As Object
Dim msg As String
Dim oParentFolder As MAPIFolder
Dim i As Integer
Dim iElement As Integer
Dim sArray() As String
Dim ArrayLen As Integer
Dim Subtractor As Integer
Dim str As String
ReDim sArray(0) As String
Set oParentFolder = objFolder
Set myItems = objFolder.Items
'Set Dict = New Scripting.Dictionary
If oParentFolder.Folders.Count Then
For i = 1 To oParentFolder.Folders.Count
If Trim(oParentFolder.Folders(i).Name) <> "" Then
iElement = IIf(sArray(0) = "", 0, UBound(sArray) + 1)
ReDim Preserve sArray(iElement) As String
sArray(iElement) = oParentFolder.Folders(i).Name
End If
Next i
Else
sArray(0) = oParentFolder.Name
End If
ArrayLen = UBound(sArray) - LBound(sArray) + 1
'MsgBox "thingy thing"
'MsgBox "thing" & sArray(1) ' This is how to iterate through the Dictionary
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
' MsgBox DateValue(ODate)
For Subtractor = 0 To (ArrayLen - 1)
If oDict.Exists(sArray(Subtractor)) Then
oDict(sArray(Subtractor)).Add
With dict
For Subtractor = 0 To (ArrayLen - 1)
If ArrayLen = 1 Then
.Add Key = objFolder.Name, Item = 0
Else
If Subtractor = 0 Then
.Add Key = CStr(sArray(Subtractor)), Item = 0
Else
End If
str = CStr(sArray(Subtractor))
End If
Next Subtractor
End With
MsgBox str
If dict.Exists(str) Then
Debug.Print (dict(str))
Else
Debug.Print ("Not Found")
End If
MsgBox dict(str)
numholder = 0
'For Each
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
' MsgBox DateValue(dateStr)
If DateValue(dateStr) >= DateValue(ODate) And DateValue(dateStr) <= DateValue(ODate2) Then
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
numholder = numholder
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
numholder = numholder + 1
End If
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
If msg = "" Then
MsgBox "There are no emails during this time range"
End If
If msg <> "" Then
MsgBox "Number of emails during date range: " & numholder
MsgBox msg
End If
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As Date
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
我要完成以下任务：
收件箱总数：3
文件夹1总计：1
文件夹2合计：1
Folder3总计：1
以及处理单击的文件夹不包含子文件夹的情况。
答案 0 :(得分：0)
我不理解您的代码。您在做事情，但不解释它们如何为您的目标做出贡献。日期处理代码似乎不相关。如果可以写代码而不必再看一遍，那么缺少注释就可以了。但是通常，在六个，十二或二十个月后，例行程序需要引起注意。可能存在无法正确处理的边缘条件，或者要求已更改。维护文档不良的代码是一场噩梦。
此答案底部的代码是我几年前编写的例程的简化版本。它并没有完全按照您的要求进行操作，也没有使用您要求的技术。也许我的代码可以接受。如果没有，我相信我已经提供了足够的解释，可以让您根据自己的要求修改代码。
首先介绍我所使用的技术。正如peakpeak所暗示的，我的代码使用递归。我还使用了集合而不是字典。这些技术未记录在代码中，因为它们是VBA的标准功能，我不在代码中记录VBA。
我不使用字典。集合提供了我所需要的所有功能。据我了解，词典与集合有很多共同点，并且具有集合所缺乏的某些功能。但对我来说更重要的是，它们缺少我认为必不可少的某些收藏功能。
您可以这样指定一个集合：
Dim Coll As New Collection
or
Dim Coll As Collection
Set Coll = New Collection
Coll.Add X将在包含X的Coll的末尾创建一个新条目。您可以在现有条目的中间添加新条目，也可以删除现有条目，但是在下面的代码中我不使用此功能。
在Coll.Add X中，X几乎可以是任何东西。它可以是一个简单值，例如字符串，long或布尔值。它可以是数组或类的实例。它不能是用户类型的实例。您无法修改集合中的条目。如果需要修改条目，则必须删除现有条目并将修改后的版本添加到同一位置。
由于集合中的条目可以是任何东西，因此需要小心。如果变量I是Long：
I = I + Coll(5)
将给出运行时错误。
如果将数组添加到Collection中，则读取它的语法可能不是立即显而易见的。考虑：
Coll.Add VBA.Array(Fldr.Name, Level, NumEmails)
假设以上Add在Coll中创建了第三个条目；那就是Coll（3）。然后：
Coll(3)(0)是FldrName Coll(3)(1)是Level Coll(3)(2)是NumEmails 请注意，我使用VBA.Array代替了Array，因为Array受Option Base语句的影响。通过使用VBA.Array，我知道下限将始终为零。
反省一下，也许这种语法并不奇怪。如果声明Dim Arr(0 To 5) As Long，则写Arr(0)来访问Arr的元素0。我的Coll(3)是一个数组，因此我写了Coll(3)(0)来访问Coll(3)的元素0。
递归是例程调用自身的地方。此技术非常适合处理树状结构。有些技术速度更快，而且不会占用大量内存，但其他任何一种技术都没有那么简单易用。
假设要处理的文件夹层次结构为：
FolderA
FolderB
FolderC
FolderD
FolderE
FolderF
FolderG
我的例程是NumEmailsByFolder，并且具有参数：
级别未在您的要求中提及，但没有级别，您将无法确定FolderF在FolderA内。我倾向于将最高级别视为0级，但是您可以使用任何您认为方便的值。
外部例程创建一个空集合，我的例程调用FldrDtls，然后调用：
NumEmailsByFolder([FolderA], 0, [FldrDtls])
[X]表示对对象X的引用。
NumEmailsByFolder计算FolderA中的电子邮件数量，将名称为“ FolderA”，级别0和电子邮件计数的条目添加到FldrDtls。然后，它调用级别1的FolderB，FolderF和FolderG。这使得代码非常简单。递归的秘密是解释器执行所有不同调用的顺序：
Calls in sequence executed Entry added to FldrDtls
NumEmailsByFolder([FolderA], 0, [FldrDtls]) FolderA 0 Count
NumEmailsByFolder([FolderB], 1, [FldrDtls]) FolderB 1 Count
NumEmailsByFolder([FolderC], 2, [FldrDtls]) FolderC 2 Count
NumEmailsByFolder([FolderD], 2, [FldrDtls]) FolderD 2 Count
NumEmailsByFolder([FolderE], 2, [FldrDtls]) FolderE 3 Count
NumEmailsByFolder([FolderF], 1, [FldrDtls]) FolderF 1 Count
NumEmailsByFolder([FolderG], 1, [FldrDtls]) FolderG 1 Count
FldrDtls中的条目按其父文件夹后的子文件夹的顺序排列。我的示例层次结构中只有四个级别，但是相同的代码将处理10或100个级别，而所有困难的工作都由解释器处理。
大多数人一开始似乎发现难以理解的递归；当然，很多年前我在大学任教的时候就做了。然后突然间，您看到了灯光，您不再理解为什么感到困难。我将其与学习驾驶汽车进行比较。在第一堂课的最后，您知道，您将永远无法转动方向盘，踩一个或多个踏板，移动变速杆，照镜子并使用指示器，同时还要避开其他道路。用户全部同时。但是几课后，您可以做更多的事情。
我的例程是：
Sub NumEmailsByFolder(ByRef FldrPrnt As Folder, ByVal Level As Long, _
ByRef FldrDtls As Collection)
' Adds an entry to FldrDtls for FldrPrnt.
' Calls itself for each immediate subfolder of FldrPrnt.
' Each entry in FldrDtls is an zero-based array containing:
' * (0) Folder name
' * (1) Level of folder within hierarchy. The level of the first (top)
' folder is as specified in the call. Each level down is one more.
' * (2) Number of emails in folder. Note: this value does not include
' any emails in any subfolders
' The external routine that calls this routine will set the parameters:
' * FldrPrnt can be a Store or a MAPIFolder at any level with the
' folder hierarchy.
' * Level might typically be set to zero or one but the initial value
' is unimportant to this routine.
' * FldrDtls would normally be an empty collection. This is not checked
' so FldrDtls may contain existing entries if this is convenient for
' the calling routine.
' On return to the external routine, the entries in FldrDtls might be:
' Inbox 0 10
' SubFldr1 1 5
' SubSubFldr1 2 3
' SubSubFldr2 2 4
' SubFldr2 1 9
Dim ErrNum As Long
Dim InxI As Long
Dim InxS As Long
Dim ItemsCrnt As Items
Dim SubFldrsCrnt As Folders
Dim NumMailItems As Long
With FldrPrnt
'Count MailItems, if any
Err.Clear
NumMailItems = 0
' In the past, I have had code crash when I attempted to access the
' Items of a folder but I have had no such error recently. This could
' be because I am now retired and my employer's Outlook installation
' had folders without items. Alternatively, it could be because
' Outlook 2016 is more robust than Outlook 2003. I use On Error to
' ensure any such error does not crash my routine.
On Error Resume Next
Set ItemsCrnt = FldrPrnt.Items
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Items does not give an error.
For InxI = 1 To ItemsCrnt.Count
If ItemsCrnt(InxI).Class = olMail Then
NumMailItems = NumMailItems + 1
End If
Next
End If
FldrDtls.Add VBA.Array(FldrPrnt.Name, Level, NumMailItems)
Set SubFldrsCrnt = FldrPrnt.Folders
' See above for explanation of On Error
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Folders does not give an error.
For InxS = 1 To SubFldrsCrnt.Count
Call NumEmailsByFolder(SubFldrsCrnt(InxS), Level + 1, FldrDtls)
Next
End If
End With
End Sub
我希望您同意该代码很简单，考虑到它可以实现的目的。如果我认为删除错误处理代码是安全的，则例程会更小。
要演示如何调用此例程，请添加以下代码：
Option Explicit
Sub TestNumEmailsByFolder()
Dim FldrDtls As Collection
Dim Fldr1 As Folder
Dim Fldr2 As Folder
Dim Fldr3 As Folder
Dim FldrCrnt As Folder
Dim FldrInx As Variant
Dim InxF As Long
Set Fldr1 = Session.Folders("johndoe@acme.com").Folders("Inbox").Folders("Test")
Set Fldr2 = Session.Folders("johndoe@acme.com").Folders("Inbox")
Set Fldr3 = Session.Folders("johndoe@acme.com")
For Each FldrInx In Array(Fldr1, Fldr2, Fldr3)
Set FldrCrnt = FldrInx
Set FldrDtls = New Collection
Call NumEmailsByFolder(FldrCrnt, 0, FldrDtls)
Debug.Print "Emails"
For InxF = 1 To FldrDtls.Count
Debug.Print PadL(FldrDtls(InxF)(2), 5) & _
Space(1 + FldrDtls(InxF)(1) * 2) & FldrDtls(InxF)(0)
Next
Next
End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
修改Set Fldr1，Set Fldr2和Set Fldr3语句以引用系统上的文件夹。我从层次结构底部的文件夹开始，然后是中间的文件夹，然后是顶部的文件夹。我建议您选择一组类似的文件夹。研究“立即窗口”的输出，并考虑如何创建列表的顺序。
这是您想要的常规吗？
它使用Collection而不是Dictionary？这有关系吗？如果我对字典的理解正确，那么字典将是不合适的。
您使用一个数组和ReDim Preserve。当您不知道需要多少个条目时，集合是一个不错的选择。就时间和内存而言，ReDim Preserve是昂贵的命令。解释器必须找到足够大的新内存块以容纳扩大的数组。它必须将值从旧数组复制到新数组并初始化新元素。最后，它必须释放旧数组以进行垃圾回收。如果我需要最终结果在数组中，那么对于这种类型的问题，我通常会在集合中构建列表，根据集合的大小对数组进行大小调整，然后将数据从集合复制到数组中。 / p>
针对文件夹的电子邮件计数不包括其子文件夹中的电子邮件。这似乎是必要条件。您无法修改集合中的条目，因此，如果有此要求，我会将其作为数组转换的一部分来处理。
子文件夹未按字母顺序列出。我从未进行过适当的调查，但是我怀疑在创建的序列中列出了子文件夹。如果这不能令人满意，则需要进行排序。有几种可能的方法。考虑到每个文件夹通常只有很少的子文件夹，我怀疑最简单的方法是最好的。如果您需要更强大的功能，可以使用快速排序实现，该实现使用索引来避免对源列表进行排序。