Option Explicit

Dim colLetters  As Collection
Dim objLetter   As Letter 'создать модуль класса Letter!
Dim FolderPath  As String

Sub main() 'запускаем эту процедуру

    Dim olApp As Object 'Outlook.Application
    Dim fldr  As Object 'Outlook.Folder
    Dim arr(), i
    Dim dateFrom As Date, dateTo As Date
    
    'задаем диапазон дат
    dateFrom = DateSerial(2010, 1, 1) 'начальная дата
    dateTo = DateSerial(2099, 12, 31) 'конечная дата (полночь, начало суток)
    
    dateTo = dateTo + TimeSerial(23, 59, 59) 'добавление полных суток к конечной дате
    Set colLetters = New Collection
    
    Set olApp = CreateObject("Outlook.Application")
    
    'обрабатываем папку Входящие и вложенные в нее
    Set fldr = olApp.Session.GetDefaultFolder(6)  '6 = olFolderInbox
    Call processFolder(fldr, dateFrom, dateTo)
    
    'обрабатываем папку Исходящие и вложенные в нее
    Set fldr = olApp.Session.GetDefaultFolder(5) '5 = olFolderSentMail
    Call processFolder(fldr, dateFrom, dateTo)
    
    'вывод в новую книгу Excel
    ReDim arr(1 To colLetters.Count, 1 To 8)
    For i = 1 To colLetters.Count
        arr(i, 1) = colLetters(i).FolderPath
        arr(i, 2) = colLetters(i).ReceivedTime
        arr(i, 3) = colLetters(i).Sender
        arr(i, 4) = colLetters(i).Subject
        arr(i, 5) = colLetters(i).To_
        arr(i, 6) = colLetters(i).CC
        arr(i, 7) = colLetters(i).BCC
        arr(i, 8) = colLetters(i).NamesAddress
    Next i
    
    With Application.Workbooks.Add.Worksheets(1)
        .Range("A1:H1") = Array("Папка", "Дата/время", "Отправитель", "Тема", "Кому", "Копия", "Скрытая копия", "Адреса участников")
        .Range("A1:H1").Font.Bold = True
        .Range("A1:H1").EntireColumn.ColumnWidth = 30
        .Range("A2").Resize(colLetters.Count, 8) = arr
    End With
    
End Sub

Sub processFolder(ByVal pFolder As Object, ByVal dateFrom As Date, ByVal dateTo As Date) 'Outlook.Folder)
    Dim fldr    As Object 'Outlook.Folder
    Dim item    As Object
    Dim mail    As Object 'Outlook.MailItem
    Dim rcpnt   As Object 'Outlook.Recipient
    Dim i
    Dim folderPathPrev As String
    Dim recpntAddr As String

    folderPathPrev = FolderPath
    FolderPath = FolderPath & "\" & pFolder.Name
    
    'перебор элементов в папке
    For Each item In pFolder.Items
        If item.Class = 43 Then 'обрабатываем только письма, 43 = olMail
            Set mail = item
            i = i + 1
            recpntAddr = ""
            'If i > 10 Then Exit For
            'Debug.Print "Письмо " & i & " в папке " & pFolder.Name
            
            If mail.ReceivedTime >= dateFrom And mail.ReceivedTime <= dateTo Then
                Set objLetter = New Letter
                
                On Error Resume Next
                With objLetter
                    .FolderPath = FolderPath
                    .ReceivedTime = mail.ReceivedTime
                    .Sender = mail.Sender
                    .Subject = mail.Subject
                    .To_ = mail.To
                    .CC = mail.CC
                    .BCC = mail.BCC
                End With
                
                recpntAddr = recpntAddr & "; " & mail.Sender & " -- " & getAddress(mail.Sender, mail.Sender.Address)
                For Each rcpnt In mail.Recipients 'цикл по получателям
                    recpntAddr = recpntAddr & "; " & rcpnt.Name & " -- " & getAddress(rcpnt.AddressEntry, rcpnt.Address)
                Next rcpnt
                recpntAddr = Mid(recpntAddr, 3)
                objLetter.NamesAddress = recpntAddr
                On Error GoTo 0
                
                colLetters.Add objLetter
            End If
            
            Set mail = Nothing
        End If
    Next item
    
    'перебор папок (первого уровня вложенности)
    For Each fldr In pFolder.Folders
        Call processFolder(fldr, dateFrom, dateTo) 'рекурсия
    Next fldr
    
    FolderPath = folderPathPrev
End Sub

Function getAddress(ByVal pAddressEntry As Object, _
                    ByVal altaddr As String)
    Dim pa      As Object 'PropertyAccessor
    Dim addr    As String
    Set pa = pAddressEntry.PropertyAccessor
    On Error Resume Next
    addr = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
    If addr = "" Then addr = altaddr
    On Error GoTo 0
    getAddress = addr
End Function