'==================================================================================

'##### 'Просмотр всех папок почты

'

'---------------------------------------------------------------------------------------

Sub PrintFoldersName()

Dim objOutlApp As Object ', oNSpace As Object, oFldr As Object

Dim x As Long, y As Long

Dim oNSpace As NameSpace

Dim oFldr As Folders

Dim oFld As MAPIFolder

'+ : oNSpace : : Object/NameSpace

'+ : oFldr : : Object/Folders

'+ : Item 1 : : Variant/Object/MAPIFolder

'1. Подключиться к Outlook

' If Not objOutlApp Is Nothing Then Exit Function

'подключаемся к Outlook

On Error Resume Next

Set objOutlApp = GetObject(, "outlook.Application")

'получаем доступ к папкам почты

Set oNSpace = objOutlApp.GetNamespace("MAPI")

'---------------------------------------------------

'2. Цикл для поиска файла подключений

'Function GetMails2()

' ConnectToOutlook

'

'просматриваем папки учетных записей и заносим в ЛистБокс

For x = 1 To oNSpace.Folders.Count

If x = 30 Then Stop

Debug.Print x & " - " & oNSpace.Folders(x).Name

'---------------------------------------------------

' 3.

'цикл по подпапкам

Set oFldr = oNSpace.Folders(oNSpace.Folders(x).Name).Folders '(2) 'входящие

For y = 1 To oFldr.Count

If y = 11 Then Stop

Debug.Print " " & x & "." & y & " - " & oFldr.Item(y).Name & " - " & oFldr.Item(y).Items.Count

Next

Next

'---------------------------------------------------

End Sub

'==================================================================================