Returns dictionary (associated array) of sub-folders and the amount of email contained within each subfolder within main folder

Question

I provided a solution to click on a folder and return how many items were contained within that folder.

Now, they've asked if that return can be kept, and broken down by sub-folders within the main folder clicked on.

Example:

INBOX has 3 sub-folders: Folder1, Folder2, Folder3

INBOX contains 3 emails of which one email comes from each sub-folder. Thus: INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1

I created a loop that gets all subfolders contained within a main folder into an array.

My next thought was to convert that to a dictionary where I pre-set the items contained to 0. Then upon forming the dictionary using the loop I'm currently using to check if something is within the date range to also see what "folder" it belongs to and add one to the value I've pre-set to zero in the dictionary (associated array) as many times as there is a "match"

Below is what I've attempted:

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

I want to accomplish the following:

INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1

as well as to handle the case where the folder that's clicked on contains no subfolders.

Returns dictionary (associated array) of sub-folders and the amount of email contained within each subfolder within main folder

Answers (1)

Related Questions