Option Explicit

Dim colAddress As Collection

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

     Dim olApp   As Object 'Outlook.Application
     Dim fldr    As Object 'Outlook.Folder
     Dim arr(), i
      
     Set colAddress = 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 colAddress.Count, 1 To 1)
     For i = 1 To colAddress.Count
         arr(i, 1) = colAddress(i)
     Next i
     Application.Workbooks.Add.Worksheets(1).Range("A1").Resize(colAddress.Count) = arr
      
End Sub

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
     Dim i

     'перебор элементов в папке
     For Each item In pFolder.Items
         If item.Class = 43 Then 'обрабатываем только письма, 43 = olMail
             Set mail = item
             i = i + 1
             'If i > 10 Then Exit For
             Debug.Print "Письмо " & i & " в папке " & pFolder.Name
             Call addAddress(mail.Sender, mail.Sender.Address) 'запоминаем отправителя
             For Each rcpnt In mail.Recipients 'цикл по получателям
                 Call addAddress(rcpnt.AddressEntry, rcpnt.Address) 'запоминаем получателя
             Next rcpnt
             Set mail = Nothing
         End If
     Next item
      
     'перебор папок (первого уровня вложенности)
     For Each fldr In pFolder.Folders
         Call processFolder(fldr) 'рекурсия
     Next fldr
End Sub

Sub addAddress(ByVal pAddressEntry As Object, _
                ByVal altaddr As String) 'Outlook.AddressEntry
     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
     colAddress.Add addr, addr 'добавляем уникальный адрес
     On Error GoTo 0
End Sub

Call addAddress(mail.Sender, mail.Sender.Address) 'запоминаем отправителя

    'обрабатываем папку Входящие и вложенные в нее
    'КОММЕНТИРУЕМ ПАПКУ ВХОДЯЩИЕ - сейчас она нам не нужна
    'Set fldr = olApp.Session.GetDefaultFolder(6)  '6 = olFolderInbox
    'Call processFolder(fldr)
    
    'обрабатываем папку Исходящие и вложенные в нее
    Set fldr = olApp.Session.GetDefaultFolder(5) '5 = olFolderSentMail
    'ДОБАВЛЯЕМ УТОЧНЕНИЕ ПАПКИ - расписываем маршрут через вложенные Folders
    Set fldr = fldr.Folders("Дни рождения").Folders("08 Август")
    Call processFolder(fldr)

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

    Dim olApp   As Object 'Outlook.Application
    Dim fldr    As Object 'Outlook.Folder
    
    Set olApp = CreateObject("Outlook.Application")
    
    'обрабатываем папку Отправленные
    PrintInCell ("Адресаты из папки Отправленные")
    Set fldr = olApp.Session.GetDefaultFolder(5)  '5 = olFolderSentMail

    For Each Item1 In fldr.Items
        'Выписываем адресатов
        If Item1.Class = 43 Then  'сообщения -  Class = 43
            str1 = Item1.To
            PrintInCell (str1)
            str1 = Item1.CC
            PrintInCell (str1)
            str1 = Item1.BCC
            PrintInCell (str1)
        End If
    Next

End Sub

Sub PrintInCell(val1 As String)
     'Пользовательская функция записи
    ActiveCell.Value = val1
    ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

    For Each Item1 In fldr.Items
        'Выписываем адресатов
        If Item1.Class = 43 Then  'сообщения -  Class = 43
            For Each rec In Item1.Recepients
                Str1 = rec.Address
                PrintInCell (Str1)
            Next          
            'str1 = Item1.To
            'PrintInCell (str1)
           ' str1 = Item1.CC
            'PrintInCell (str1)
            'str1 = Item1.BCC
            'PrintInCell (str1)
        End If
    Next

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

Dim olApp As Object 'Outlook.Application
Dim fldr As Object 'Outlook.Folder

Set olApp = CreateObject("Outlook.Application")

'обрабатываем папку Отправленные
PrintInCell ("Адресаты из папки Отправленные")
Set fldr = olApp.Session.GetDefaultFolder(5) '5 = olFolderSentMail

For Each Item1 In fldr.Items
'Выписываем адресатов
If Item1.Class = 43 Then 'сообщения - Class = 43
str1 = Item1.To
PrintInCell (str1)
str1 = Item1.CC
PrintInCell (str1)
str1 = Item1.BCC
PrintInCell (str1)
End If
Next

End Sub

Sub PrintInCell(val1 As String)
'Пользовательская функция записи
ActiveCell.Value = val1
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub