Script that counts the no of mails in each folder need a change. Outlook Macro.

hi,

Script that counts the no of mails in each folder need a change. Outlook Macro.
When run i want the script to get the count from all the folders below the folder i have selected also. And mention the folder name and the data .

REgards
Sharath

Sub Count_Messages_As_Per_Subject()
'Macro when run gets no of similar subject mails for Sophos
    'Change the file name and path as desired.
    Const HTML_FILE = "D:\Subject Counts.html"
    Dim olkFolder As Outlook.MAPIFolder, _
        olkItem As Object, _
        dicItems As Object, _
        arrSubjects As Variant, _
        arrCounts As Variant, _
        objFSO As Object, _
        objFile As Object, _
        strBuffer As String, _
        objIE As Object
    Set olkFolder = Application.ActiveExplorer.CurrentFolder
    Set dicItems = CreateObject("Scripting.Dictionary")
    For Each olkItem In olkFolder.Items
        If dicItems.Exists(olkItem.Subject) Then
            dicItems.Item(olkItem.Subject) = dicItems.Item(olkItem.Subject) + 1
        Else
            dicItems.Add olkItem.Subject, 1
        End If
    Next
    Set olkItem = Nothing
    Set olkFolder = Nothing
    arrSubjects = dicItems.Keys()
    arrCounts = dicItems.Items()
    For intIndex = LBound(arrSubjects) To UBound(arrSubjects)
        strBuffer = strBuffer & "  <tr><td>" & arrSubjects(intIndex) & "</td><td>" & arrCounts(intIndex) & "</td></tr>" & vbCrLf
    Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile(HTML_FILE)
    objFile.WriteLine "<table>"
    objFile.WriteLine strBuffer
    objFile.WriteLine "</table>"
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Navigate2 "file:\\" & HTML_FILE
    Do Until objIE.readyState = 4
        DoEvents
    Loop
    objIE.Visible = True
    Set objIE = Nothing
End Sub

Select allOpen in new window