【发布时间】：2019-04-11 14:59:40
【问题描述】：
我提供了一个解决方案来单击一个文件夹并返回该文件夹中包含的项目数。
现在，他们询问是否可以保留该退货，并按点击的主文件夹中的子文件夹进行细分。
例子：
INBOX 有 3 个子文件夹：Folder1、Folder2、Folder3
INBOX 包含 3 封电子邮件，其中一封来自每个子文件夹。
因此：
收件箱总数：3
文件夹 1 总计：1
文件夹 2 总数：1
文件夹 3 总数：1
我创建了一个循环，将主文件夹中包含的所有子文件夹放入一个数组中。
我的下一个想法是将其转换为字典，在其中我将包含的项目预设为 0。然后在使用循环形成字典时，我正在使用当前用于检查某些内容是否在日期范围内以查看什么它所属的“文件夹”并将我在字典（关联数组）中预设为零的值加一，与“匹配”一样多次
以下是我尝试过的：
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
文件夹 3 总数：1
以及处理单击的文件夹不包含子文件夹的情况。
【问题讨论】：
-
请详细说明：不在起作用吗？
-
嗨@peakpeak，我最初尝试使用 Dictionary 实例将 sArray 转换为字典（然后我发现还有一个 scripting.dictionary 并查看它是否具有不同的属性）- - 它不会像我预期的那样附加到字典中，而是会删除以前包含的内容，并用 With Dict 语句替换“附加”到字典中的内容。这就是我现在卡住的地方。我也很好奇这是否是最好的方法，或者是否有更好的方法，但根据当前的思路，这是目前的卡住。
-
更好是一把多刃剑。为了什么？您需要定义在没有“更好”方法的情况下要完成的工作。那么变量太多
-
@peakpeak，我需要能够在单击 Outlook 应用程序上的文件夹时返回某个日期范围内的电子邮件数量（我的代码确实正确处理了日期范围部分以及主要文件夹部分）按主文件夹和子文件夹分组。
-
好吧，我再说一遍：什么不起作用？
标签： vba loops dictionary outlook