Option Explicit

'В Tools\References включить ссылку на Microsoft Outlook 15.0 Object Library
'если нет 15.0, то на ту которая есть

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

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

    Dim olApp As Outlook.Application
    Dim fldr  As Outlook.Folder
    Dim arr(), i
    
    Set colLetters = New Collection
    
    Set olApp = CreateObject("Outlook.Application")
    
    'обрабатываем папку Входящие и вложенные в нее
    Set fldr = olApp.Session.GetDefaultFolder(6)  '6 = olFolderInbox
    Call processFolder(fldr)
    
    'обрабатываем папку Исходящие и вложенные в нее
    Set fldr = olApp.Session.GetDefaultFolder(5) '5 = olFolderSentMail
    Call processFolder(fldr)
       
    'вывод в новую книгу 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 Outlook.Folder) 'Outlook.Folder)
    Dim fldr    As Outlook.Folder
    Dim item    As Object
    Dim mail    As Outlook.MailItem
    Dim rcpnt   As 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
            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
            
            Set mail = Nothing
        End If
    Next item
    
    'перебор папок (первого уровня вложенности)
    For Each fldr In pFolder.Folders
        Call processFolder(fldr) 'рекурсия
    Next fldr
    
    FolderPath = folderPathPrev
End Sub

Function getAddress(ByVal pAddressEntry As Object, _
                    ByVal altaddr As String)
    Dim pa      As 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

Option Explicit

Public FolderPath   As String
Public ReceivedTime As Date
Public Sender       As String
Public Subject      As String
Public To_          As String
Public CC           As String
Public BCC          As String
Public NamesAddress As String

Sub processFolder(ByVal pFolder As Outlook.Folder) 'Outlook.Folder)

Option Explicit

'В Tools\References включить ссылку на Microsoft Outlook 15.0 Object Library
'если нет 15.0, то на ту которая есть

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

..........

Sub processFolder(ByVal pFolder As Object) 'Outlook.Folder)
    Dim fldr    As Object 'Outlook.Folder
    Dim item    As Object
    Dim mail    As Object 'Outlook.MailItem
    Dim rcpnt   As Object 'Outlook.Recipient

[s]Sub processFolder(ByVal pFolder As Outlook.Folder) 'Outlook.Folder)[/s]

Sub processFolder(ByVal pFolder As Object) 'Outlook.Folder)

    Dim pa      As Object 'PropertyAccessor