Возвращает словарь (связанный массив) подпапок и количество сообщений электронной почты, содержащихся в каждой подпапке в основной папке

Question

Я предоставил решение щелкнуть по папке и вернуть количество элементов, которые содержались в этой папке.

Теперь они спросили, можно ли сохранить этот возврат и разбить по подпапкам внутринажата основная папка.

Пример:

INBOX имеет 3 подпапки: Папка1, Папка2, Папка3

INBOX содержит 3 электронных письма, из которых одно письмо приходит от каждого суб-folder.Таким образом: INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 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

Я хочу выполнить следующее:

Всего INBOX: 3
Всего папок 1: 1
Всего папок 2: 1
Всего папок 3:1

, а также для случая, когда в папке, по которой вы щелкнули, нет подпапок.

Answer 1

Я не понимаю ваш код.Вы делаете вещи, но не объясняете, как они способствуют достижению вашей цели.Существует код обработки даты, который не имеет отношения к делу.Если бы кто-то мог написать код и больше никогда не смотреть на него, отсутствие комментариев было бы в порядке.Но обычно после шести, двенадцати или двадцати месяцев рутина требует некоторого внимания.Возможно, существует граничное условие, которое обрабатывается неправильно, или, возможно, требование изменилось.Ведение плохо документированного кода - это кошмар.

Код внизу этого ответа - упрощенная версия процедуры, которую я написал несколько лет назад.Он не делает именно то, что вы запрашиваете, и не использует технику, которую вы запрашиваете.Возможно, мой код будет приемлемым.Если нет, я думаю, что я включил достаточно объяснений, чтобы вы могли изменить мой код в соответствии с вашими требованиями.

Сначала ознакомьтесь с методами, которые я использовал.Как предполагает peakpeak, мой код использует рекурсию.Я также использовал коллекцию вместо словаря.Эти методы не описаны в коде, потому что они являются стандартными функциями VBA, и я не документирую VBA в своем коде.

Я не использую словари.Коллекции предоставляют все функции, которые мне когда-либо требовались.Словари, насколько я понимаю, имеют много общего с коллекциями и имеют некоторую функциональность, которой нет в коллекциях.Но что более важно для меня, им не хватает некоторых функциональных возможностей коллекций, которые я считаю необходимыми.

Вы указываете коллекцию так:

   Dim Coll As New Collection
or
   Dim Coll As Collection
   Set Coll = New Collection

Coll.Add X создаст новую запись в конце Coll, содержащую X. Вы можете добавить новые записи в середине существующих записей, и выможет удалить существующие записи, но я не использую эту функциональность в приведенном ниже коде.

В Coll.Add X X может быть практически любым.Это может быть простое значение, такое как строка, long или логическое значение.Это может быть массив или экземпляр класса.Это не может быть экземпляр типа пользователя.Вы не можете изменить запись в коллекции.Если вам нужно изменить запись, вы должны удалить существующую запись и добавить исправленную версию в той же позиции.

Поскольку запись в коллекции может быть чем угодно, вам нужно быть осторожным.Если переменная I является длинной:

I = I + Coll(5)

выдаст ошибку времени выполнения, если Coll (5) является строкой или чем-то еще, что не может быть добавлено к длинной.

Если вы добавитемассив в коллекцию, синтаксис для его чтения, пожалуй, не сразу очевиден.Рассмотрим:

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, поскольку оператор Option Base влияет на Array.Используя VBA.Array, я знаю, что нижняя граница всегда будет равна нулю.

При отражении, возможно, этот синтаксис не так уж странен.Если я объявляю Dim Arr(0 To 5) As Long, я пишу Arr(0) для доступа к элементу 0 из Arr.Мой Coll(3) - это массив, поэтому я пишу Coll(3)(0) для доступа к элементу 0 из Coll(3).

Рекурсия - это когда процедура вызывает себя сама.Этот метод идеален для обработки древовидных структур.Существуют методы, которые работают быстрее и не так интенсивно используют память, но ни один из этих других методов не так прост в использовании.

Предположим, что иерархия папок для обработки:

FolderA
  FolderB
    FolderC
    FolderD
      FolderE
  FolderF 
  FolderG

Myподпрограмма NumEmailsByFolder и имеет параметры:

1. Ссылка на папку верхнего уровня
2. Длинный уровень
3. Ссылка на коллекцию FldrDtls

Уровень не упоминается в вашем требовании, но без него вы не сможете сказать, что FolderF находится внутри FolderA.Я склонен считать верхний уровень уровнем 0, но вы можете использовать любое значение, которое вам удобно.

Внешняя процедура создает пустую коллекцию, которую моя процедура вызывает FldrDtls, а затем вызывает:

NumEmailsByFolder([FolderA], 0, [FldrDtls]) 

Где [X] указывает ссылку на объект X.

NumEmailsByFolder подсчитывает количество писем в FolderA, добавляет запись в FldrDtls с именем «FolderA», уровень 0 и счетчик писем.Затем он вызывает себя для FolderB, FolderF и FolderG с уровнем 1. Это делает довольно простой код.Секрет рекурсии заключается в последовательности, в которой интерпретатор выполняет все различные вызовы:

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 операторы для ссылки на папки в вашей системе.Я начал с папки в нижней части иерархии, затем папки в середине и затем папки в верхней части.Я предлагаю вам выбрать аналогичный набор папок.Изучите вывод в «Немедленное окно» и подумайте, как была создана последовательность списка.

Вам нужна эта процедура?

В ней вместо словаря используется коллекция?Имеет ли это значение?Если мое понимание словарей правильное, словарь будет неуместным.

Вы используете массив и ReDim Preserve.Коллекция - хороший выбор, когда вы не знаете, сколько записей потребуется.ReDim Preserve - дорогая команда с точки зрения времени и памяти.Интерпретатор должен найти новый блок памяти, достаточно большой для увеличенного массива.Он должен скопировать значения из старого массива в новый и инициализировать новые элементы.Наконец, он должен освободить старый массив для сборки мусора.Если мне нужно, чтобы конечный результат находился в массиве, то при такой проблеме я обычно строю список в коллекции, изменяю размер массива в соответствии с размером коллекции и затем копирую данные из коллекции в массив.

Количество сообщений электронной почты в папке не включает сообщения электронной почты в ее подпапках.Похоже, это требование.Вы не можете изменить запись в коллекции, поэтому, если это требование, я бы обработал ее как часть преобразования в массив.

Подпапки не перечислены в алфавитном порядке.Я никогда не исследовал должным образом, но я подозреваю, что подпапки перечислены в созданной последовательности.Если это неудовлетворительно, вам понадобится сортировка.Есть несколько возможных подходов.Учитывая, что в каждой папке обычно будет небольшое количество подпапок, я подозреваю, что самый простой подход будет лучшим.Если вам нужно что-то более мощное, у меня есть реализация быстрой сортировки, которая использует индексы, чтобы избежать сортировки списка источников.